(define-module (gib-gab-gob ui catbird)
  #:use-module (catbird)
  #:use-module (catbird input-map)
  #:use-module (catbird mode)
  #:use-module (catbird node)
  #:use-module (catbird node-2d)
  #:use-module (catbird region)
  #:use-module ((catbird scene)
                #:select (<scene> current-scene replace-major-mode))
  #:use-module (chickadee)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee math vector)
  #:use-module (chickadee scripting)
  #:use-module (oop goops))

(define %window-width 1024)
(define %window-height 768)

(define %tile-width 64.0)
(define %tile-height 64.0)

(define-class <tile> (<node-2d>)
  (tile-x #:getter tile-x #:init-keyword #:tile-x)
  (tile-y #:getter tile-y #:init-keyword #:tile-y))

(define-class <board-view> (<node-2d>)
  (vat #:getter vat #:init-keyword #:vat)
  (board #:getter board #:init-keyword #:board)
  (tiles #:accessor tiles #:init-value #()))

(define-method (on-boot (board-view <board-view>))
  (define tile-container
    (make <node-2d>
      #:name 'tile-container
      #:rank 1))
  (define background
    (make <canvas>
      #:name 'background
      #:painter
      (with-style ((fill-color db32-elf-green))
                  (fill
                   rectangle (vec2 0.0 0.0)
                   %window-width
                   %window-height))))
  (resize board-view %window-width %window-height)
  (attach-to board-view tile-container))

(define-method (tile-ref (garden <garden-view>) x y)
  (vector-ref (vector-ref (tiles garden) y) x))

(define-method (rebuild-tiles (board-view <board-view>))
  (let* ((container (& board-view tile-container)))
    (for-each-tile
     (λ (x y tile)
       (detach tile))
     (tiles board-view))
    (set! (tiles garden)
          (vector-unfold
           (λ (y)
             (vector-unfold
              (λ (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 <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))
              3))
           3))
    (for-each-tile
     (λ (x y tile)
       (if (= y 0)
           (set! (position-y tile)
                 (* %tile-height (- 3 1)))
           (place-below (tile-ref board-view x (- y 1)) tile))
       (unless (= x 0)
         (place-right (tile-ref board-view (- x 1) y) tile)))
     (tiles board-view))
    (set! (width container) (* 3 %tile-width))
    (set! (height container) (* 3 %tile-height))
    (center-in-parent container)))

(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 (board-pick (board <board-view>) x y)
  (define (find-tile node)
    (cond
     ((not node)
      #f)
     ((is-a? node <tile>)
      node)
     ((parent node)
      (find-tile (parent node)))
     (else #f)))
  (find-tile (pick board (vec2 x y) (lambda _ #t))))

(define-class <board-mode> (<major-mode>))

(define-method (make-move (mode <board-mode>) x y)
  (define board (& (current-scene) root board))
  (define node (board-pick board x y))
  (cond
   ((is-a? node <tile>)
    (board-make-move board node))))

(bind-input <board-mode> (mouse-press 'left) make-move)

(define* (launch-game node-thunk)
  (run-catbird
   (lambda ()
     (let ((region (create-full-region #:name 'main))
           (scene (make <scene> #:name 'board)))
       (replace-scene region scene)
       (replace-major-mode scene (make <board-mode>))
       (set! (camera region)
             (make <camera-2d>
               #:width %window-width
               #:height %window-height))
       (attach-to scene (node-thunk))))
   #:title "Gib Gab Gob"
   #:width %window-width
   #:height %window-height))