1 files changed, 145 insertions, 0 deletions
diff --git a/lisparuga/gui.scm b/lisparuga/gui.scm
new file mode 100644
index 0000000..9f60526
--- /dev/null
+++ b/lisparuga/gui.scm
@@ -0,0 +1,145 @@
+;;; Lisparuga
+;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Lisparuga 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.
+;;;
+;;; Lisparuga 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 Lisparuga.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; 2D Graphical User Interface
+;;
+;;; Code:
+
+(define-module (lisparuga gui)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee render color)
+  #:use-module (chickadee render font)
+  #:use-module (chickadee render shapes)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (lisparuga node)
+  #:use-module (lisparuga node-2d)
+  #:export (<widget>
+            width
+            height
+
+            <label-widget>
+
+            <margin-container>
+            left
+            right
+            bottom
+            top))
+
+
+;;;
+;;; Base Widget
+;;;
+
+(define *draw-bounding-boxes?* #t)
+(define %bounding-box-color (make-color 1.0 0.0 1.0 0.2))
+
+(define-class <widget> (<node-2d>)
+  (width #:accessor width #:init-keyword #:width #:init-form 0.0)
+  (height #:accessor height #:init-keyword #:height #:init-form 0.0)
+  (min-width #:accessor min-width #:init-keyword #:min-width #:init-form 0.0)
+  (min-height #:accessor min-height #:init-keyword #:min-height #:init-form 0.0)
+  (bounding-box #:getter bounding-box #:init-form (make-rect 0.0 0.0 0.0 0.0))
+  (dirty-bounding-box? #:accessor dirty-bounding-box? #:init-form #t))
+
+(define-method (dirty! (widget <widget>))
+  (set! (dirty-bounding-box? widget) #t)
+  (next-method))
+
+(define-method ((setter width) (widget <widget>) w)
+  (slot-set! widget 'width (pk 'new-width (max (min-width widget) w)))
+  (dirty! widget))
+
+(define-method ((setter height) (widget <widget>) h)
+  (slot-set! widget 'height (max (min-height widget) h))
+  (dirty! widget))
+
+(define-method (update (widget <widget>) dt)
+  (when (dirty-bounding-box? widget)
+    (let ((bb (bounding-box widget))
+          (w (width widget))
+          (h (height widget)))
+      (set-rect-width! bb w)
+      (set-rect-height! bb h))
+    (set! (dirty-bounding-box? widget) #f)))
+
+(define-method (render (widget <widget>) alpha)
+  (draw-filled-rect (bounding-box widget) %bounding-box-color
+                    #:matrix (world-matrix widget))
+  (next-method))
+
+
+;;;
+;;; Text Label
+;;;
+
+(define-class <label-widget> (<widget>)
+  (text #:accessor text #:init-keyword #:text #:init-form ""))
+
+(define-method ((setter text) (label <label-widget>) new-text)
+  (set! (text (& label label)) new-text)
+  (next-method))
+
+(define-method (on-boot (label <label-widget>))
+  (attach-to label
+             (make <label>
+               #:name 'label
+               #:text (text label))))
+
+
+;;;
+;;; Margin Container
+;;;
+
+(define-class <margin-container> (<widget>)
+  (left #:accessor left #:init-keyword #:left #:init-form 0.0)
+  (right #:accessor right #:init-keyword #:right #:init-form 0.0)
+  (bottom #:accessor bottom #:init-keyword #:bottom #:init-form 0.0)
+  (top #:accessor top #:init-keyword #:top #:init-form 0.0)
+  (needs-resize? #:accessor needs-resize? #:init-form #t))
+
+(define-method (on-attach (container <margin-container>) (widget <widget>))
+  (set! (needs-resize? container) #t))
+
+(define-method (on-detach (container <margin-container>) (widget <widget>))
+  (set! (needs-resize? container) #t))
+
+(define-method (update (container <margin-container>) dt)
+  (when (needs-resize? container)
+    (let loop ((c (children container))
+               (w 0.0)
+               (h 0.0))
+      (match c
+        (()
+         (set! (width container) (pk 'new-width (+ w (left container) (right container))))
+         (set! (height container) (+ h (bottom container) (top container)))
+         (for-each (lambda (child)
+                     (when (is-a? child <widget>)
+                       (set! (width child) w)
+                       (set! (height child) h)
+                       (teleport child (left container) (bottom container))))
+                   (children container)))
+        ((child . rest)
+         (if (is-a? child <widget>)
+             (loop rest
+                   (max w (min-width child))
+                   (max h (min-height child)))
+             (loop rest w h)))))
+    (set! (needs-resize? container) #f))
+  (next-method))