;;; Lisparuga
;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
;;;
;;; Lisparuga 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.
;;;
;;; Lisparuga 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 Lisparuga.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; 2D Graphical User Interface
;;
;;; Code:

(define-module (lisparuga gui)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee render color)
  #:use-module (chickadee render font)
  #:use-module (chickadee render shapes)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (lisparuga node)
  #:use-module (lisparuga node-2d)
  #:export (<widget>
            width
            height

            <label-widget>

            <margin-container>
            left
            right
            bottom
            top))


;;;
;;; Base Widget
;;;

(define *draw-bounding-boxes?* #t)
(define %bounding-box-color (make-color 1.0 0.0 1.0 0.2))

(define-class <widget> (<node-2d>)
  (width #:accessor width #:init-keyword #:width #:init-form 0.0)
  (height #:accessor height #:init-keyword #:height #:init-form 0.0)
  (min-width #:accessor min-width #:init-keyword #:min-width #:init-form 0.0)
  (min-height #:accessor min-height #:init-keyword #:min-height #:init-form 0.0)
  (bounding-box #:getter bounding-box #:init-form (make-rect 0.0 0.0 0.0 0.0))
  (dirty-bounding-box? #:accessor dirty-bounding-box? #:init-form #t))

(define-method (dirty! (widget <widget>))
  (set! (dirty-bounding-box? widget) #t)
  (next-method))

(define-method ((setter width) (widget <widget>) w)
  (slot-set! widget 'width (pk 'new-width (max (min-width widget) w)))
  (dirty! widget))

(define-method ((setter height) (widget <widget>) h)
  (slot-set! widget 'height (max (min-height widget) h))
  (dirty! widget))

(define-method (update (widget <widget>) dt)
  (when (dirty-bounding-box? widget)
    (let ((bb (bounding-box widget))
          (w (width widget))
          (h (height widget)))
      (set-rect-width! bb w)
      (set-rect-height! bb h))
    (set! (dirty-bounding-box? widget) #f)))

(define-method (render (widget <widget>) alpha)
  (draw-filled-rect (bounding-box widget) %bounding-box-color
                    #:matrix (world-matrix widget))
  (next-method))


;;;
;;; Text Label
;;;

(define-class <label-widget> (<widget>)
  (text #:accessor text #:init-keyword #:text #:init-form ""))

(define-method ((setter text) (label <label-widget>) new-text)
  (set! (text (& label label)) new-text)
  (next-method))

(define-method (on-boot (label <label-widget>))
  (attach-to label
             (make <label>
               #:name 'label
               #:text (text label))))


;;;
;;; Margin Container
;;;

(define-class <margin-container> (<widget>)
  (left #:accessor left #:init-keyword #:left #:init-form 0.0)
  (right #:accessor right #:init-keyword #:right #:init-form 0.0)
  (bottom #:accessor bottom #:init-keyword #:bottom #:init-form 0.0)
  (top #:accessor top #:init-keyword #:top #:init-form 0.0)
  (needs-resize? #:accessor needs-resize? #:init-form #t))

(define-method (on-attach (container <margin-container>) (widget <widget>))
  (set! (needs-resize? container) #t))

(define-method (on-detach (container <margin-container>) (widget <widget>))
  (set! (needs-resize? container) #t))

(define-method (update (container <margin-container>) dt)
  (when (needs-resize? container)
    (let loop ((c (children container))
               (w 0.0)
               (h 0.0))
      (match c
        (()
         (set! (width container) (pk 'new-width (+ w (left container) (right container))))
         (set! (height container) (+ h (bottom container) (top container)))
         (for-each (lambda (child)
                     (when (is-a? child <widget>)
                       (set! (width child) w)
                       (set! (height child) h)
                       (teleport child (left container) (bottom container))))
                   (children container)))
        ((child . rest)
         (if (is-a? child <widget>)
             (loop rest
                   (max w (min-width child))
                   (max h (min-height child)))
             (loop rest w h)))))
    (set! (needs-resize? container) #f))
  (next-method))