summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am1
-rw-r--r--starling/gui.scm485
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))