path: root/community-garden.scm

(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)
             (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))

(define garden-vat (spawn-vat))
(define catbird-vat (spawn-vat))
(define alice-vat (spawn-vat))
(define-vat-run garden-run garden-vat)
(define-vat-run catbird-run catbird-vat)
(define-vat-run alice-run alice-vat)

(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)))

(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
  (garden-run ($ the-botanist 'approve-plant sunflower)))
(define cabbage/approved
  (garden-run ($ the-botanist 'approve-plant cabbage)))
(define our-garden
  (garden-run
   (spawn ^garden
          "Spritely Institute Community Garden"
          (make-garden-bed 8 8)
          the-garden-gate)))

(define alice (alice-run (spawn ^gardener "Alice" our-garden)))
(alice-run ($ alice 'plant 1 1 sunflower/approved))
(alice-run ($ alice 'plant 2 1 sunflower/approved))
(alice-run ($ alice 'plant 1 2 sunflower/approved))
(alice-run ($ alice 'plant 2 2 sunflower/approved))
(alice-run ($ alice 'plant 5 1 cabbage/approved))
(alice-run ($ alice 'plant 6 1 cabbage/approved))
(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))
(catbird-run
 (on ($ catbird-visitor 'get-garden-name)
     (lambda (name)
       (atomic-box-set! catbird-garden-name name))))
(catbird-run
 (on ($ catbird-visitor 'inspect-garden)
     (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))

(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))
         (scene (make <scene> #:name 'scratch)))
     (replace-scene region scene)
     (set! (camera region)
           (make <camera-2d>
             #:width %window-width
             #:height %window-height))
     (attach-to scene
                (make <canvas>
                  #:name 'background
                  #:painter
                  (with-style ((fill-color db32-elf-green))
                    (fill
                     (rectangle (vec2 0.0 0.0)
                                %window-width
                                %window-height)))))
     (attach-to scene (make-garden-view))))
 #:title "Community Garden"
 #:width %window-width
 #:height %window-height)