diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | community-garden.scm | 310 | ||||
| -rw-r--r-- | community-garden/actors.scm | 62 | ||||
| -rw-r--r-- | community-garden/garden-bed.scm | 74 | ||||
| -rw-r--r-- | community-garden/plant.scm | 20 | ||||
| -rw-r--r-- | community-garden/view.scm | 159 |
7 files changed, 331 insertions, 299 deletions
@@ -1,3 +1,4 @@ +*.go /Makefile /Makefile.in /aclocal.m4 diff --git a/Makefile.am b/Makefile.am index a571bce..de95d08 100644 --- a/Makefile.am +++ b/Makefile.am @@ -22,4 +22,8 @@ moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION) godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache SOURCES = \ + community-garden/plant.scm \ + community-garden/garden-bed.scm \ + community-garden/actors.scm \ + community-garden/view.scm \ community-garden.scm diff --git a/community-garden.scm b/community-garden.scm index 35d28f9..a121b39 100644 --- a/community-garden.scm +++ b/community-garden.scm @@ -1,113 +1,23 @@ (setenv "CATBIRD_DEV_MODE" "1") (use-modules (catbird) - (catbird asset) (catbird camera) (catbird kernel) (catbird node) (catbird node-2d) (catbird region) ((catbird scene) #:select (<scene>)) - (chickadee config) (chickadee graphics color) (chickadee graphics path) - (chickadee graphics text) - (chickadee graphics texture) (chickadee math vector) - (chickadee scripting) + (community-garden actors) + (community-garden garden-bed) + (community-garden plant) + (community-garden view) (goblins) - (goblins actor-lib cell) - (goblins actor-lib methods) - (goblins utils simple-sealers) (goblins vrun) (ice-9 atomic) - (ice-9 match) - (oop goops) - (srfi srfi-1) - (srfi srfi-9) - (srfi srfi-43)) - - -;;; -;;; Data types -;;; - -(define-record-type <plant> - (make-plant name char) - plant? - (name plant-name) - (char plant-char)) - -(define sunflower (make-plant "Sunflower" #\S)) -(define cabbage (make-plant "Cabbage" #\C)) -(define winter-squash (make-plant "Winter Squash" #\W)) - -(define (list-replace lst i o) - (let loop ((j 0) - (lst lst)) - (match lst - ((head . rest) - (if (= i j) - (cons o rest) - (cons head (loop (+ j 1) rest))))))) - -(define (make-empty-row width) - (make-list width #f)) - -(define (make-empty-bed width height) - (list-tabulate height - (lambda (_i) - (make-empty-row width)))) - -(define (bed-ref bed x y) - (list-ref (list-ref bed y) x)) - -(define (bed-set bed x y o) - (list-replace bed y (list-replace (list-ref bed y) x o))) - -(define-record-type <garden-bed> - (%make-garden-bed width height tiles) - garden-bed? - (width garden-bed-width) - (height garden-bed-height) - (tiles garden-bed-tiles)) - -(define (make-garden-bed width height) - (%make-garden-bed width height (make-empty-bed width height))) - -(define (bounds-check garden x y) - (unless (and (>= x 0) - (>= y 0) - (< x (garden-bed-width garden)) - (< y (garden-bed-height garden))) - (error "garden tile out of bounds" x y))) - -(define (garden-bed-ref garden x y) - (bounds-check garden x y) - (bed-ref (garden-bed-tiles garden) x y)) - -(define (garden-bed-set garden x y o) - (bounds-check garden x y) - (%make-garden-bed (garden-bed-width garden) - (garden-bed-height garden) - (bed-set (garden-bed-tiles garden) x y o))) - -(define (display-garden-bed garden) - (for-each (lambda (row) - (for-each (lambda (tile) - (display - (if (plant? tile) - (plant-char tile) - ".")) - (display " ")) - row) - (newline)) - (garden-bed-tiles garden))) - - -;;; -;;; Actors -;;; + (oop goops)) (define garden-vat (spawn-vat)) (define catbird-vat (spawn-vat)) @@ -116,58 +26,6 @@ (define-vat-run catbird-run catbird-vat) (define-vat-run alice-run alice-vat) -(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)))) - (define the-botanist (garden-run (spawn ^botanist))) (define the-garden-gate (garden-run (spawn ^garden-gate the-botanist))) (define sunflower/approved @@ -191,7 +49,6 @@ (alice-run ($ alice 'plant 5 2 cabbage/approved)) (alice-run ($ alice 'plant 6 2 cabbage/approved)) - (define catbird-visitor (catbird-run (spawn ^visitor "Catbird UI" our-garden))) (define catbird-garden-bed (make-atomic-box #f)) (define catbird-garden-name (make-atomic-box #f)) @@ -204,155 +61,6 @@ (lambda (garden-bed) (atomic-box-set! catbird-garden-bed garden-bed)))) -(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)) - - -;;; -;;; Catbird visualization -;;; - -(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 (make-garden-view) - (make <garden-view> - #:rank 1 - #:vat catbird-vat - #:visitor catbird-visitor - #:name-box catbird-garden-name - #:garden-bed-box catbird-garden-bed)) - -(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) - (catbird-run - (on ($ catbird-visitor 'inspect-garden) - (lambda (garden-bed) - (atomic-box-set! catbird-garden-bed 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 (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-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)) - (run-catbird (lambda () (let ((region (create-full-region #:name 'main)) @@ -370,8 +78,12 @@ (fill (rectangle (vec2 0.0 0.0) %window-width - %window-height))))) - (attach-to scene (make-garden-view)))) + %window-height)))) + (make <garden-view> + #:vat catbird-vat + #:visitor catbird-visitor + #:name-box catbird-garden-name + #:garden-bed-box catbird-garden-bed)))) #:title "Community Garden" #:width %window-width #:height %window-height) diff --git a/community-garden/actors.scm b/community-garden/actors.scm new file mode 100644 index 0000000..b34d1f8 --- /dev/null +++ b/community-garden/actors.scm @@ -0,0 +1,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)))) diff --git a/community-garden/garden-bed.scm b/community-garden/garden-bed.scm new file mode 100644 index 0000000..71cf6e6 --- /dev/null +++ b/community-garden/garden-bed.scm @@ -0,0 +1,74 @@ +(define-module (community-garden garden-bed) + #:use-module (community-garden plant) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (make-garden-bed + garden-bed? + garden-bed-width + garden-bed-height + garden-bed-tiles + garden-bed-ref + garden-bed-set)) + +(define (list-replace lst i o) + (let loop ((j 0) + (lst lst)) + (match lst + ((head . rest) + (if (= i j) + (cons o rest) + (cons head (loop (+ j 1) rest))))))) + +(define (make-empty-row width) + (make-list width #f)) + +(define (make-empty-bed width height) + (list-tabulate height + (lambda (_i) + (make-empty-row width)))) + +(define (bed-ref bed x y) + (list-ref (list-ref bed y) x)) + +(define (bed-set bed x y o) + (list-replace bed y (list-replace (list-ref bed y) x o))) + +(define-record-type <garden-bed> + (%make-garden-bed width height tiles) + garden-bed? + (width garden-bed-width) + (height garden-bed-height) + (tiles garden-bed-tiles)) + +(define (make-garden-bed width height) + (%make-garden-bed width height (make-empty-bed width height))) + +(define (bounds-check garden x y) + (unless (and (>= x 0) + (>= y 0) + (< x (garden-bed-width garden)) + (< y (garden-bed-height garden))) + (error "garden tile out of bounds" x y))) + +(define (garden-bed-ref garden x y) + (bounds-check garden x y) + (bed-ref (garden-bed-tiles garden) x y)) + +(define (garden-bed-set garden x y o) + (bounds-check garden x y) + (%make-garden-bed (garden-bed-width garden) + (garden-bed-height garden) + (bed-set (garden-bed-tiles garden) x y o))) + +(define (display-garden-bed garden) + (for-each (lambda (row) + (for-each (lambda (tile) + (display + (if (plant? tile) + (plant-char tile) + ".")) + (display " ")) + row) + (newline)) + (garden-bed-tiles garden))) diff --git a/community-garden/plant.scm b/community-garden/plant.scm new file mode 100644 index 0000000..3f034b8 --- /dev/null +++ b/community-garden/plant.scm @@ -0,0 +1,20 @@ +(define-module (community-garden plant) + #:use-module (srfi srfi-9) + #:export (make-plant + plant? + plant-name + plant-char + + sunflower + cabbage + winter-squash)) + +(define-record-type <plant> + (make-plant name char) + plant? + (name plant-name) + (char plant-char)) + +(define sunflower (make-plant "Sunflower" #\S)) +(define cabbage (make-plant "Cabbage" #\C)) +(define winter-squash (make-plant "Winter Squash" #\W)) 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)) |