path: root/community-garden/view.scm

(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)
  #: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>
            <garden-mode>))

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

(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 (or (garden-name garden) "Untitled")
      #: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
     ((vat garden)
      (lambda ()
        (on (user garden)
            (lambda (user)
              (on (<- user 'inspect-garden)
                  (lambda (garden-bed)
                    (atomic-box-set! (garden-bed-box garden) garden-bed)))))))
     (sleep 0.5))))

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

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