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