(use-modules (catbird)
             (catbird asset)
             (catbird camera)
             (catbird kernel)
             (catbird mixins)
             (catbird mode)
             (catbird node)
             (catbird node-2d)
             (catbird region)
             (catbird scene)
             (chickadee graphics texture)
             (chickadee graphics sprite)
             (chickadee math vector)
             (chickadee utils)
             (ice-9 match)
             (oop goops))

(define %default-width 640)
(define %default-height 480)
(define-asset (%tileset (file "assets/images/tiles.png"))
  (load-tileset file 32 32))

(define (make-empty-sprite-batch)
  (make-sprite-batch #f))

(define-class <tile> ()
  (mine? #:accessor mine? #:init-value #f)
  (flag? #:accessor flag? #:init-value #f)
  (revealed? #:accessor revealed? #:init-value #f)
  (neighbor-mines #:accessor neighbor-mines #:init-value 0))

(define-class <minefield> (<node-2d>)
  (field-width #:accessor field-width #:init-keyword #:width #:init-value 10)
  (field-height #:accessor field-height #:init-keyword #:height #:init-value 10)
  (field #:accessor field)
  (mines #:accessor mines #:init-keyword mines #:init-value 10)
  (batch #:accessor batch #:init-thunk make-empty-sprite-batch))

(define-method (initialize (minefield <minefield>) initargs)
  (next-method)
  (reset-field minefield))

(define-method (field-ref (minefield <minefield>) x y)
  (vector-ref (vector-ref (field minefield) y) x))

(define-method (reset-field (minefield <minefield>))
  ;; Build new vector of vectors.
  (define h (field-height minefield))
  (define w (field-width minefield))
  (define new-field (make-vector h))
  (for-range ((y h))
    (let ((new-row (make-vector w)))
      (for-range ((x w))
        (vector-set! new-row x (make <tile>)))
      (vector-set! new-field y new-row)))
  (set! (field minefield) new-field)
  ;; Add mines.
  (let loop ((i 0))
    (when (< i (mines minefield))
      (let ((x (random w))
            (y (random h)))
        ;; Try again if we randomly picked the same place more than
        ;; once.
        (let ((tile (field-ref minefield x y)))
          (if (mine? tile)
              (loop i)
              (begin
                (set! (mine? tile) #t)
                (loop (+ i 1))))))))
  (resize minefield (* w 32.0) (* h 32.0))
  (refresh-sprites minefield))

(define-method (refresh-sprites (minefield <minefield>))
  (set-sprite-batch-texture! (batch minefield)
                             (texture-parent
                              (texture-atlas-ref (artifact %tileset) 0)))
  (sprite-batch-clear! (batch minefield))
  (for-range ((x (field-width minefield))
              (y (field-height minefield)))
    (let* ((tile (field-ref minefield x y))
           (i (cond
               ((and (revealed? tile) (mine? tile)) 2)
               ((revealed? tile) (+ 3 (neighbor-mines tile)))
               ((flag? tile) 1)
               (else 0))))
      (sprite-batch-add! (batch minefield)
                         (vec2 (* x 32.0) (* y 32.0))
                         #:texture-region
                         (texture-atlas-ref (artifact %tileset) i)))))

(define-method (render (minefield <minefield>) _alpha)
  (draw-sprite-batch* (batch minefield) (world-matrix minefield)))

(define-method (in-bounds? (minefield <minefield>) x y)
  (and (>= x 0) (>= y 0)
       (< x (field-width minefield))
       (< y (field-height minefield))))

(define-method (mine-location? (minefield <minefield>) x y)
  (and (in-bounds? minefield x y)
       (mine? (field-ref minefield x y))))

(define-method (empty-location? (minefield <minefield>) x y)
  (and (in-bounds? minefield x y)
       (not (mine? (field-ref minefield x y)))))

(define-method (count-neighboring-mines (minefield <minefield>) x y)
  (+ (if (mine-location? minefield (- x 1) (- y 1)) 1 0)
     (if (mine-location? minefield x (- y 1)) 1 0)
     (if (mine-location? minefield (+ x 1) (- y 1)) 1 0)
     (if (mine-location? minefield (- x 1) y) 1 0)
     (if (mine-location? minefield (+ x 1) y) 1 0)
     (if (mine-location? minefield (- x 1) (+ y 1)) 1 0)
     (if (mine-location? minefield x (+ y 1)) 1 0)
     (if (mine-location? minefield (+ x 1) (+ y 1)) 1 0)))

(define-method (reveal-if-empty (minefield <minefield>) x y)
  (and (empty-location? minefield x y) (reveal minefield x y)))

(define-method (reveal (minefield <minefield>) x y)
  (let ((tile (field-ref minefield x y)))
    (unless (or (revealed? tile) (flag? tile))
      (set! (revealed? tile) #t)
      (unless (mine? tile)
        (let ((n (count-neighboring-mines minefield x y)))
          (set! (neighbor-mines tile) n)
          (when (= n 0)
            (reveal-if-empty minefield (- x 1) (- y 1))
            (reveal-if-empty minefield x (- y 1))
            (reveal-if-empty minefield (+ x 1) (- y 1))
            (reveal-if-empty minefield (- x 1) y)
            (reveal-if-empty minefield (+ x 1) y)
            (reveal-if-empty minefield (- x 1) (+ y 1))
            (reveal-if-empty minefield x (+ y 1))
            (reveal-if-empty minefield (+ x 1) (+ y 1))))))))

(define-method (toggle-flag (minefield <minefield>) x y)
  (let ((tile (field-ref minefield x y)))
    (set! (flag? tile) (not (flag? tile)))))

(define-method (field-state (minefield <minefield>))
  (let y-loop ((y 0) (state 'win))
    (if (< y (field-height minefield))
        (case (let x-loop ((x 0) (state 'win))
                (if (< x (field-width minefield))
                    (let ((tile (field-ref minefield x y)))
                      (cond
                       ((and (revealed? tile) (mine? tile))
                        'lose)
                       ((and (not (revealed? tile)) (not (mine? tile)))
                        (x-loop (+ x 1) 'in-progress))
                       (else
                        (x-loop (+ x 1) state))))
                    state))
          ((win)
           (y-loop (+ y 1) state))
          ((lose) 'lose)
          ((in-progress)
           (y-loop (+ y 1) 'in-progress)))
        state)))

(define-method (local->tile p)
  (let ((tx (inexact->exact (floor (/ (vec2-x p) 32.0))))
        (ty (inexact->exact (floor (/ (vec2-y p) 32.0)))))
    (values tx ty)))

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

(define-method (on-enter (mode <minesweeper-mode>))
  (let ((minefield (make <minefield> #:name 'minefield)))
    (attach-to (parent mode) minefield)
    (center-in-parent minefield)))

(define (world->tile node p)
  (local->tile (world->local node p)))

(define-method (pick-tile (mode <minesweeper-mode>) x y proc)
  (let* ((p (vec2 x y))
         (picked (pick (parent mode) p)))
    (when picked
      (call-with-values (lambda () (world->tile picked p))
        (lambda (tx ty)
          (proc picked tx ty))))))

(define-method (on-primary-click (mode <minesweeper-mode>) x y)
  (pick-tile mode x y
             (lambda (minefield tx ty)
               (reveal minefield tx ty)
               (refresh-sprites minefield)
               (case (field-state minefield)
                 ((win)
                  (push-major-mode (parent mode)
                                   (make <reset-game-mode>
                                     #:message "YOU WIN")))
                 ((lose)
                  (push-major-mode (parent mode)
                                   (make <reset-game-mode>
                                     #:message "OOPSIES :(")))))))

(define-method (on-alt-click (mode <minesweeper-mode>) x y)
  (pick-tile mode x y
             (lambda (minefield tx ty)
               (toggle-flag minefield tx ty)
               (refresh-sprites minefield))))

(bind-input <minesweeper-mode> (mouse-release 'left) on-primary-click)
(bind-input <minesweeper-mode> (mouse-release 'right) on-alt-click)

(define-class <reset-game-mode> (<major-mode>)
  (message #:accessor message #:init-keyword #:message))

(define-method (on-enter (mode <reset-game-mode>))
  (let ((msg (make <label>
               #:name 'message
               #:text (message mode)
               #:rank 99)))
    (attach-to (parent mode) msg)
    (center-horizontal-in-parent msg)
    (set! (position-y msg) (- (height (parent mode)) 48.0))))

(define-method (on-primary-click (mode <reset-game-mode>) x y)
  (let ((scene (parent mode)))
    (detach (& scene message))
    (reset-field (& (parent mode) minefield))
    (pop-major-mode (parent mode))))

(bind-input <reset-game-mode> (mouse-release 'left) on-primary-click)

(define (launch-game)
  (let ((region (create-full-region #:name 'main))
        (scene (make <scene> #:name 'minesweeper)))
    (replace-scene region scene)
    (set-camera region (make <camera-2d>))
    (replace-major-mode scene (make <minesweeper-mode>))))

(when (batch-mode?)
  (run-catbird launch-game
               #:width %default-width
               #:height %default-height))