;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; 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)
  #:use-module (web uri)
  #:export (accepts-cursor-focus?
            on-cursor-enter
            on-cursor-exit
            on-primary-press
            on-primary-click

            <ui-mode>

            <container>
            layout

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

            <horizontal-container>
            padding

            <vertical-container>

            <link>
            uri

            <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 (needs-layout? (node <node>)) #f)

(define-method (initialize (container <container>) initargs)
  (next-method)
  (layout container))

(define-method (layout (container <container>))
  (for-each-child (lambda (child)
                    (when (needs-layout? child)
                      (layout child)))
                  container))

(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 (on-child-resize (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 (layout (container <margin-container>))
  (next-method)
  (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>))
  (next-method)
  (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>))
  (next-method)
  (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))))))


;;;
;;; Links
;;;

(define-class <link> (<label>)
  (uri #:accessor uri #:init-keyword #:uri #:init-value #f))

(define-method (initialize (link <link>) initargs)
  (next-method)
  ;; Automatically convert strings to URI objects.
  (when (string? (uri link))
    (set! (uri link) (string->uri (uri link))))
  ;; If no link text was given, default to the URI string.
  (when (string-null? (text link))
    (set! (text link) (uri->string (uri link))))
  (set! (color link) tango-aluminium-1))

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

;; TODO: Make this customizable.  Even better, tap into the desktop
;; environment to open with preferred programs.
(define-method (visit-uri (link <link>))
  (let ((uri (uri link)))
    (case (uri-scheme uri)
      ((file)
       (let ((args (match (string-split (uri-path uri) #\:)
                     ((file)
                      (list file))
                     ((file line)
                      (list (string-append "+" line) file))
                     ((file line column)
                      (list (string-append "+" line ":" column) file)))))
         (apply system* "emacsclient" "-n" args))))))

(define-method (on-cursor-enter (link <link>))
  (set! (color link) blue)
  (next-method))

(define-method (on-cursor-exit (link <link>))
  (set! (color link) tango-aluminium-1)
  (next-method))

(define-method (on-primary-click (link <link>))
  (pk 'link link)
  (when (uri link)
    (visit-uri link))
  (next-method))


;;;
;;; 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 (initialize (button <button>) initargs)
  (next-method)
  (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))