path: root/starling/gui.scm

;;; 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>
            apply-theme
            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))