Add beginnings of UI widget module.

2 files changed, 341 insertions, 0 deletions

diff --git a/Makefile.am b/Makefile.am
index 1fb5a2b..5351101 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -50,6 +50,7 @@ SOURCES = 					\
   catbird/camera.scm				\
   catbird/node.scm				\
   catbird/node-2d.scm				\
+  catbird/ui.scm				\
   catbird/scene.scm				\
   catbird/region.scm				\
   catbird/kernel.scm				\
diff --git a/catbird/ui.scm b/catbird/ui.scm
new file mode 100644
index 0000000..fcd3427
--- /dev/null
+++ b/catbird/ui.scm
@@ -0,0 +1,340 @@
+;;; 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))