;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Catbird is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Catbird is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Catbird.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Graphical user interface widgets.
;;
;;; Code:
(define-module (catbird ui)
  #:use-module (catbird input-map)
  #:use-module (catbird mixins)
  #:use-module (catbird mode)
  #:use-module (catbird node)
  #:use-module (catbird node-2d)
  #:use-module (catbird scene)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee graphics text)
  #:use-module (chickadee math vector)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)
  #:export (accepts-cursor-focus?
            on-cursor-enter
            on-cursor-exit
            on-primary-press
            on-primary-click

            <ui-mode>

            <container>

            <margin-container>
            margin
            margin-left
            margin-right
            margin-bottom
            margin-top

            <horizontal-container>
            padding

            <vertical-container>

            <button>
            background-up
            background-down
            background-over))


;;;
;;; General purpose UI methods

(define-method (accepts-cursor-focus? (node <node>))
  #f)

(define-method (on-cursor-enter (node <node>))
  (send node 'cursor-enter))

(define-method (on-cursor-exit (node <node>))
  (send node 'cursor-exit))

(define-method (on-primary-press (node <node>))
  (send node 'primary-press))

(define-method (on-primary-click (node <node>))
  (send node 'primary-click))


;;;
;;; UI Mode
;;;

(define-class <ui-mode> (<minor-mode>)
  (cursor-focus #:accessor cursor-focus #:init-value #f))

(define (pick-focusable x y)
  (let loop ((node (pick (current-scene) (vec2 x y))))
    (cond
     ((not node)
      #f)
     ((accepts-cursor-focus? node)
      node)
     (else
      (loop (parent node))))))

(define-method (do-mouse-move (mode <ui-mode>) x y x-rel y-rel)
  (let ((focus (cursor-focus mode))
        (node (pick-focusable x y)))
    (unless (eq? focus node)
      (set! (cursor-focus mode) node)
      (and=> focus on-cursor-exit)
      (and=> node on-cursor-enter))))

(define-method (do-mouse-press-primary (mode <ui-mode>) x y)
  (and=> (cursor-focus mode) on-primary-press))

(define-method (do-mouse-click-primary (mode <ui-mode>) x y)
  (and=> (cursor-focus mode) on-primary-click))

(bind-input <ui-mode> (mouse-move) do-mouse-move)
(bind-input <ui-mode> (mouse-press 'left) do-mouse-press-primary)
(bind-input <ui-mode> (mouse-release 'left) do-mouse-click-primary)


;;;
;;; Containers
;;;

(define (max-child-width node)
  (fold (lambda (child w)
          (max (width child) w))
        0.0
        (children node)))

(define (max-child-height node)
  (fold (lambda (child h)
          (max (height child) h))
        0.0
        (children node)))

(define-class <container> (<node-2d>)
  (needs-layout? #:accessor needs-layout? #:init-value #t))

(define-method (layout (container <container>))
  #t)

(define-method (on-attach (container <container>) child)
  (set! (needs-layout? container) #t))

(define-method (on-detach (container <container>) child)
  (set! (needs-layout? container) #t))

(define-method (update (container <container>) dt)
  (when (needs-layout? container)
    (layout container)
    (set! (needs-layout? container) #f)))

(define-class <margin-container> (<container>)
  (margin-left #:accessor margin-left
               #:init-keyword #:margin-left
               #:init-value 0.0)
  (margin-right #:accessor margin-right
                #:init-keyword #:margin-right
                #:init-value 0.0)
  (margin-bottom #:accessor margin-bottom
                 #:init-keyword #:margin-bottom
                 #:init-value 0.0)
  (margin-top #:accessor margin-top
              #:init-keyword #:margin-top
              #:init-value 0.0)
  (margin #:allocation #:virtual
          #:accessor margin
          #:init-keyword #:margin
          #:slot-ref
          (lambda (c)
            (let ((l (margin-left c))
                  (r (margin-right c))
                  (b (margin-bottom c))
                  (t (margin-top c)))
              (and (= l r b t) l)))
          #:slot-set!
          (lambda (c m)
            (set! (margin-left c) m)
            (set! (margin-right c) m)
            (set! (margin-bottom c) m)
            (set! (margin-top c) m))))

(define-method ((setter margin-left) (container <margin-container>) m)
  (slot-set! container 'margin-left m)
  (set! (needs-layout? container) #t))

(define-method ((setter margin-right) (container <margin-container>) m)
  (slot-set! container 'margin-right m)
  (set! (needs-layout? container) #t))

(define-method ((setter margin-bottom) (container <margin-container>) m)
  (slot-set! container 'margin-bottom m)
  (set! (needs-layout? container) #t))

(define-method ((setter margin-top) (container <margin-container>) m)
  (slot-set! container 'margin-top m)
  (set! (needs-layout? container) #t))

(define-method (on-child-resize (container <container>) child)
  (set! (needs-layout? container) #t))

(define-method (layout (container <margin-container>))
  (for-each-child (lambda (child)
                    (place-at child
                              (margin-left container)
                              (margin-bottom container)))
                  container)
  (resize container
          (+ (max-child-width container)
             (margin-left container)
             (margin-right container))
          (+ (max-child-height container)
             (margin-bottom container)
             (margin-top container))))

(define-class <horizontal-container> (<container>)
  (padding #:accessor padding #:init-keyword #:padding #:init-value 0.0))

(define-method (layout (container <horizontal-container>))
  (let ((p (padding container)))
    (let loop ((kids (children container))
               (prev #f))
      (match kids
        (()
         (fit-to-children container))
        ((node . rest)
         (if prev
             (place-right prev node #:padding p)
             (place-at-x node 0.0))
         (place-at-y node 0.0)
         (loop rest node))))))

(define-class <vertical-container> (<container>)
  (padding #:accessor padding #:init-keyword #:padding #:init-value 0.0))

(define-method (layout (container <vertical-container>))
  (let ((p (padding container)))
    (let loop ((kids (children container))
               (prev #f))
      (match kids
        (()
         (fit-to-children container))
        ((node . rest)
         (if prev
             (place-above prev node #:padding p)
             (place-at-y node 0.0))
         (place-at-x node 0.0)
         (loop rest node))))))


;;;
;;; Buttons
;;;

(define (make-empty-node)
  (make <node-2d>))

(define-class <button> (<node-2d>)
  (padding #:accessor padding #:init-keyword #:padding #:init-value 0.0)
  (background-up #:accessor background-up
                 #:init-keyword #:background-up
                 #:init-thunk make-empty-node)
  (background-down #:accessor background-down
                   #:init-keyword #:background-down
                   #:init-thunk make-empty-node)
  (background-over #:accessor background-over
                   #:init-keyword #:background-over
                   #:init-thunk make-empty-node))

(define-method (update-background (button <button>))
  (resize (background-up button) (width button) (height button))
  (resize (background-down button) (width button) (height button))
  (resize (background-over button) (width button) (height button)))

(define-method (hide-background (button <button>))
  (hide (background-up button))
  (hide (background-down button))
  (hide (background-over button)))

(define-method (refit (button <button>))
  (hide-background button)
  (fit-to-children button (padding button))
  (show (background-up button)))

(define-method (on-boot (button <button>))
  (let ((bg-up (background-up button))
        (bg-down (background-down button))
        (bg-over (background-over button)))
    (set! (rank bg-up) 0)
    (set! (rank bg-down) 0)
    (set! (rank bg-over) 0)
    (attach-to button
               (background-up button)
               (background-down button)
               (background-over button))
    (refit button)))

(define (background? button child)
  (or (eq? (background-up button) child)
      (eq? (background-down button) child)
      (eq? (background-over button) child)))

(define-method (on-attach (button <button>) child)
  (unless (background? button child)
    ;; Backgrounds have rank 0, other children must have at least rank
    ;; 1.
    (set! (rank child) (max (rank child) 1))
    (refit button)))

(define-method (on-child-resize (button <button>) child)
  (unless (background? button child)
    (refit button)))

(define-method (accepts-cursor-focus? (button <button>))
  #t)

(define-method (on-change (button <button>) slot-name old new)
  (case slot-name
    ((width height)
     (update-background button)))
  (next-method))

(define-method (on-cursor-enter (button <button>))
  (hide-background button)
  (show (background-over button))
  (next-method))

(define-method (on-cursor-exit (button <button>))
  (hide-background button)
  (show (background-up button))
  (next-method))

(define-method (on-primary-press (button <button>))
  (hide-background button)
  (show (background-down button))
  (next-method))

(define-method (on-primary-click (button <button>))
  (hide-background button)
  (show (background-over button))
  (next-method))