Add beginnings of a graphical user interface widget module.

2 files changed, 486 insertions, 0 deletions

diff --git a/Makefile.am b/Makefile.am
index aa89d2c..22c997f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -50,6 +50,7 @@ SOURCES = 					\
   starling/minibuffer.scm			\
   starling/kernel.scm				\
   starling/node-2d.scm				\
+  starling/gui.scm				\
   starling/transition.scm
 
 EXTRA_DIST += 					\
diff --git a/starling/gui.scm b/starling/gui.scm
new file mode 100644
index 0000000..614dfc0
--- /dev/null
+++ b/starling/gui.scm
@@ -0,0 +1,485 @@
+;;; Starling Game Engine
+;;; Copyright © 2019 David Thompson <davet@gnu.org>
+;;;
+;;; This program 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.
+;;;
+;;; This program 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 Starling.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; 2D Graphical User Interface
+;;
+;;; Code:
+
+(define-module (starling gui)
+  #:use-module (chickadee config)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics font)
+  #:use-module (chickadee graphics texture)
+  #:use-module (chickadee math vector)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:use-module (starling asset)
+  #:use-module (starling config)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:use-module (starling scene)
+  #:export (<theme>
+            settings
+            theme-ref
+            define-theme
+            current-theme
+            <widget>
+            focused?
+            hover?
+            left-pressed?
+            right-pressed?
+            middle-pressed?
+            add-listener
+            remove-listener
+            notify
+            mouse-enter
+            mouse-exit
+            mouse-press
+            mouse-click
+            <gui-scene>
+            <container>
+            <horizontal-container>
+            <vertical-container>
+            <margin-container>
+            left-margin
+            right-margin
+            bottom-margin
+            top-margin
+            <button>
+            text))
+
+
+;;;
+;;; Meta Widget
+;;;
+
+(define-class <meta-widget>
+  ((if developer-mode? <meta-node> <developer-meta-node>))
+  (themeables #:allocation #:class #:init-thunk make-hash-table))
+
+(define (themeables)
+  (class-slot-ref <meta-widget> 'themeables))
+
+(define-method (themeable-slot? (slot <slot>))
+  (get-keyword #:themeable? (slot-definition-options slot)))
+
+(define-method (compute-slots (class <meta-widget>))
+  (fold (lambda (slot memo)
+          (cons (if (themeable-slot? slot)
+                    (let ((name (slot-definition-name slot))
+                          (default (if (slot-definition-init-thunk slot)
+                                       ((slot-definition-init-thunk slot))
+                                       (slot-definition-init-value slot))))
+                      (apply make (class-of slot)
+                             #:allocation #:virtual
+                             #:slot-ref (lambda (obj)
+                                          (theme-ref (theme obj) class name default))
+                             #:slot-set! (lambda (obj v) #t)
+                             (let loop ((options (slot-definition-options slot)))
+                               (match options
+                                 (() '())
+                                 (((or #:allocation #:slot-ref #:slot-set!) _ . rest)
+                                  (loop rest))
+                                 ((kw arg . rest)
+                                  (cons* kw arg (loop rest)))))))
+                    slot)
+                memo))
+        '()
+        (next-method)))
+
+(define-method (initialize (class <meta-widget>) initargs)
+  (next-method)
+  (hashq-set! (themeables)
+              class
+              (fold (lambda (slot memo)
+                      (if (themeable-slot? slot)
+                          (cons (slot-definition-name slot) memo)
+                          memo))
+                    '()
+                    (class-slots class))))
+
+
+;;;
+;;; Base Widget
+;;;
+
+(define-asset default-font
+  (load-font (scope-datadir "fonts/Inconsolata-Regular.otf") 12))
+
+(define current-theme (make-parameter #f))
+
+(define-class <widget> (<node-2d>)
+  (focused? #:accessor focused? #:init-value #f #:watch? #t)
+  (hover? #:accessor hover? #:init-value #f #:watch? #t)
+  (left-pressed? #:accessor left-pressed? #:init-value #f #:watch? #t)
+  (right-pressed? #:accessor right-pressed? #:init-value #f #:watch? #t)
+  (middle-pressed? #:accessor middle-pressed? #:init-value #f #:watch? #t)
+  (listeners #:getter listeners #:init-thunk make-hash-table)
+  (theme #:accessor theme #:init-keyword #:theme #:init-thunk current-theme
+         #:watch? #t)
+  (background #:getter background #:init-value #f #:themeable? #t)
+  (font #:getter font #:init-value default-font #:themeable? #t)
+  #:metaclass <meta-widget>)
+
+(define-method (initialize (widget <widget>) initargs)
+  (next-method)
+  (for-each (match-lambda
+              ((name . proc)
+               (add-listener widget name proc)))
+            (get-keyword #:listeners initargs '())))
+
+(define-method (add-listener (widget <widget>) name proc)
+  (let ((t (listeners widget)))
+    (hashq-set! t name (cons proc (hashq-ref t name '())))))
+
+(define-method (remove-listener (widget <widget>) name proc)
+  (let ((t (listeners widget)))
+    (hashq-set! t name (delq proc (hashq-ref t name '())))))
+
+(define-method (notify (widget <widget>) event-name . args)
+  (let loop ((procs (hashq-ref (listeners widget) event-name '())))
+    (match procs
+      (()
+       ;; No listener handled this event, send event to parent widget.
+       (let ((p (parent widget)))
+         (and p (is-a? p <widget>) (apply notify p event-name args))))
+      ((proc . rest)
+       ;; If an event handler returns a value other than #f, we
+       ;; consider the event to be handled and stop.
+       (or (apply proc widget args)
+           (loop rest))))))
+
+(define-method (mouse-press (widget <widget>) button)
+  (match button
+    ('left (set! (left-pressed? widget) #t))
+    ('right (set! (right-pressed? widget) #t))
+    ('middle (set! (middle-pressed? widget) #t)))
+  (notify widget 'press button))
+
+(define-method (mouse-click (widget <widget>) button)
+  (match button
+    ('left (set! (left-pressed? widget) #f))
+    ('right (set! (right-pressed? widget) #f))
+    ('middle (set! (middle-pressed? widget) #f)))
+  (notify widget 'click button))
+
+(define-method (mouse-enter (widget <widget>) buttons)
+  (for-each (match-lambda
+              ('left (set! (left-pressed? widget) #t))
+              ('right (set! (right-pressed? widget) #t))
+              ('middle (set! (middle-pressed? widget) #t)))
+            buttons)
+  (set! (hover? widget) #t)
+  (notify widget 'enter))
+
+(define-method (mouse-exit (widget <widget>))
+  (set! (left-pressed? widget) #f)
+  (set! (right-pressed? widget) #f)
+  (set! (middle-pressed? widget) #f)
+  (set! (hover? widget) #f)
+  (notify widget 'exit))
+
+;; Implementors of this method need to be idempotent so that themes
+;; can be changed during runtime.
+(define-method (apply-theme (widget <widget>))
+  (when (background widget)
+    (replace widget
+             (make <9-patch>
+               #:name 'background
+               #:texture (background widget)
+               #:margin 4.0
+               #:width (width widget)
+               #:height (height widget)))))
+
+(define-method (refresh-background-size (widget <widget>))
+  (let ((bg (& widget background)))
+    (when bg
+      (set! (width bg) (width widget))
+      (set! (height bg) (height widget)))))
+
+(define-method (on-change (widget <widget>) slot-name old new)
+  (case slot-name
+    ((theme)
+     (apply-theme widget))
+    ((width height)
+     (refresh-background-size widget)
+     (next-method))
+    (else
+     (next-method))))
+
+(define-method (on-boot (widget <widget>))
+  (apply-theme widget))
+
+
+;;;
+;;; Theme
+;;;
+
+(define-class <theme> ()
+  (settings #:getter settings #:init-keyword #:settings #:init-form '()))
+
+(define-method (validate-settings (theme <theme>))
+  (let ((t (themeables)))
+    (for-each (match-lambda
+                ((class . class-settings)
+                 (let ((slot-names (hashq-ref t class '())))
+                   (for-each (match-lambda
+                               ((key . _)
+                                (unless (memq key slot-names)
+                                  (error "non-themeable slot for class"
+                                         class key))))
+                             class-settings))))
+              (settings theme))))
+
+(define-method (initialize (theme <theme>) initargs)
+  (next-method)
+  (validate-settings theme))
+
+(define %unthemed-value (cons 'unthemed 'value))
+
+(define (unthemed-value? obj)
+  (eq? obj %unthemed-value))
+
+(define-method (theme-ref theme class name)
+  %unthemed-value)
+
+(define-method (theme-ref theme class name default)
+  default)
+
+(define-method (theme-ref (theme <theme>) (class <meta-widget>) name)
+  (match (assq name (or (assq-ref (settings theme) class) '()))
+    (#f
+     (let loop ((supers (class-direct-supers class)))
+       (match supers
+         (() %unthemed-value)
+         ((super . rest)
+          (let ((val (theme-ref theme super name)))
+            (if (unthemed-value? val)
+                (loop rest)
+                val))))))
+    ((key . value)
+     value)))
+
+(define-method (theme-ref (theme <theme>) class name default)
+  (let ((val (theme-ref theme class name)))
+    (if (unthemed-value? val)
+        default
+        val)))
+
+(define-syntax-rule (define-theme name (class (slot-name value) ...) ...)
+  (define name
+    (make <theme>
+      #:settings `((,class . ((slot-name . ,value) ...)) ...))))
+
+
+;;;
+;;; GUI Scene
+;;;
+
+;; A special scene that manages who the mouse is over, who has
+;; keyboard focus, etc.
+(define-class <gui-scene> (<scene-2d>)
+  (mouse-focus #:accessor mouse-focus #:init-value #f)
+  (keyboard-focus #:accessor keyboard-focus #:init-value #f))
+
+(define-method (pick-widget (scene <gui-scene>) p)
+  (pick scene p (lambda (node) (is-a? node <widget>))))
+
+(define-method (on-mouse-move (scene <gui-scene>) x y x-rel y-rel buttons)
+  (let ((focused (mouse-focus scene))
+        (picked (pick-widget scene (vec2 x y))))
+    (unless (eq? focused picked)
+      (set! (mouse-focus scene) picked)
+      (when focused
+        (mouse-exit focused))
+      (when picked
+        (mouse-enter picked buttons)))))
+
+(define-method (on-mouse-release (scene <gui-scene>) button x y)
+  (when (mouse-focus scene)
+    (mouse-click (mouse-focus scene) button)))
+
+(define-method (on-mouse-press (scene <gui-scene>) button clicks x y)
+  (when (mouse-focus scene)
+    (mouse-press (mouse-focus scene) button)))
+
+
+;;;
+;;; Container
+;;;
+
+(define-class <container> (<widget>)
+  (refresh-layout? #:accessor refresh-layout? #:init-form #t))
+
+(define-method (refresh-layout (container <container>))
+  #t)
+
+(define-method (on-child-resize (container <container>) child)
+  (set! (refresh-layout? container) #t))
+
+(define-method (on-attach (container <container>) child)
+  (set! (refresh-layout? container) #t))
+
+(define-method (on-detach (container <container>) child)
+  (set! (refresh-layout? container) #t))
+
+(define-method (update (container <container>) dt)
+  (next-method)
+  (when (refresh-layout? container)
+    (refresh-layout container)
+    (set! (refresh-layout? container) #f)))
+
+
+
+
+;;;
+;;; Horizontal Container
+;;;
+
+(define-class <horizontal-container> (<container>))
+
+(define-method (refresh-layout (container <horizontal-container>))
+  (let loop ((kids (children container))
+             (w 0.0)
+             (h 0.0))
+    (match kids
+      (()
+       (set! (width container) w)
+       (set! (height container) h))
+      ((child . rest)
+       (set! (position-x child) (- w (origin-x child)))
+       (set! (position-y child) (- (origin-x child)))
+       (loop rest
+             (+ w (width child))
+             (max h (height child)))))))
+
+
+;;;
+;;; Vertical Container
+;;;
+
+(define-class <vertical-container> (<container>))
+
+(define-method (refresh-layout (container <vertical-container>))
+  ;; We want the nodes stacked top to bottom, but the y origin is on
+  ;; the bottom of the screen.  The simple iteration used in the
+  ;; horizontal layout won't work here because it would result in a
+  ;; bottom to top stacking.  To deal with this, we traverse the
+  ;; children twice.  Once to find the sum of all node heights, and
+  ;; once more to stack them top to bottom.
+  (let loop ((kids (children container))
+             (w 0.0)
+             (h (fold (lambda (child sum)
+                        (+ (height child) sum))
+                      0.0 (children container))))
+    (set! (height container) h)
+    (match kids
+      (()
+       (set! (width container) w))
+      ((child . rest)
+       (set! (position-x child) (- (origin-x child)))
+       (set! (position-y child)  (- h (origin-y child) (height child)))
+       (loop rest (max w (width child)) (- h (height child)))))))
+
+
+;;;
+;;; Margin Container
+;;;
+
+(define-class <margin-container> (<container>)
+  (left-margin #:accessor left-margin #:init-keyword #:left #:watch? #t)
+  (right-margin #:accessor right-margin #:init-keyword #:right #:watch? #t)
+  (bottom-margin #:accessor bottom-margin #:init-keyword #:bottom #:watch? #t)
+  (top-margin #:accessor top-margin #:init-keyword #:top #:watch? #t))
+
+(define-method (initialize (container <margin-container>) initargs)
+  (let ((default-margin (get-keyword #:margin initargs 0.0)))
+    (slot-set! container 'left-margin default-margin)
+    (slot-set! container 'right-margin default-margin)
+    (slot-set! container 'bottom-margin default-margin)
+    (slot-set! container 'top-margin default-margin))
+  (next-method))
+
+(define-method (refresh-layout (container <margin-container>))
+  (let loop ((kids (children container))
+             (w 0.0)
+             (h 0.0))
+    (match kids
+      (()
+       (set! (width container)
+             (+ w (left-margin container) (right-margin container)))
+       (set! (height container)
+             (+ h (bottom-margin container) (top-margin container))))
+      ((child . rest)
+       (set! (position-x child) (- (left-margin container) (origin-x child)))
+       (set! (position-y child) (- (bottom-margin container) (origin-y child)))
+       (loop rest (max w (width child)) (max h (height child)))))))
+
+(define-method (on-change (container <margin-container>) slot-name old new)
+  (case slot-name
+    ((left-margin right-margin bottom-margin top-margin)
+     (set! (refresh-layout? container) #t))
+    (else
+     (next-method))))
+
+
+;;;
+;;; Button
+;;;
+
+(define-class <button> (<widget>)
+  (text #:accessor text #:init-keyword #:text #:watch? #t)
+  (press-background #:getter press-background #:init-value #f #:themeable? #t))
+
+(define-method (refresh-label-position (button <button>))
+  (set! (position-x (& button label)) (/ (width button) 2.0))
+  (set! (position-y (& button label)) (/ (height button) 2.0)))
+
+(define-method (refresh-background-texture (button <button>))
+  (let ((bg (& button background)))
+    (when bg
+      (set! (texture bg)
+            (if (left-pressed? button)
+                (press-background button)
+                (background button))))))
+
+(define-method (on-change (button <button>) slot-name old new)
+  (case slot-name
+    ((width height)
+     (refresh-label-position button)
+     (next-method))
+    ((text)
+     (set! (text (& button label)) new))
+    ((left-pressed?)
+     (refresh-background-texture button))
+    (else
+     (next-method))))
+
+(define-method (apply-theme (button <button>))
+  (next-method)
+  (replace button
+    (make <label>
+      #:name 'label
+      #:rank 1
+      #:font (font button)
+      #:text (text button)
+      #:align 'center
+      #:vertical-align 'center))
+  (refresh-label-position button)
+  (refresh-background-texture button))