diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | starling/gui.scm | 485 |
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)) |