Day 1 progress.

1 files changed, 47 insertions, 0 deletions

diff --git a/apple-town-fair/dialog-box.scm b/apple-town-fair/dialog-box.scm
new file mode 100644
index 0000000..0731e72
--- /dev/null
+++ b/apple-town-fair/dialog-box.scm
@@ -0,0 +1,47 @@
+;;; Copyright © 2022 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 this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+(define-module (apple-town-fair dialog-box)
+  #:use-module (apple-town-fair assets)
+  #:use-module (apple-town-fair common)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee math vector)
+  #:use-module (oop goops)
+  #:export (<dialog-box>))
+
+(define-class <dialog-box> (<node-2d>)
+  (text #:accessor text #:init-keyword #:text #:init-value "" #:observe? #t))
+
+(define-method (on-boot (dialog <dialog-box>))
+  (attach-to dialog
+             (make <sprite>
+               #:name 'background
+               #:texture dialog-box-image)
+             (make <label>
+               #:name 'label
+               #:rank 1
+               #:font monogram-font
+               #:vertical-align 'top
+               #:text (text dialog)))
+  (set! (width dialog) (width (& dialog background)))
+  (set! (height dialog) (height (& dialog background)))
+  (teleport (& dialog label) 10.0 (- (height dialog) 10.0)))
+
+(define-method (on-change (dialog <dialog-box>) slot old new)
+  (case slot
+    ((text)
+     (set! (text (& dialog label)) new))))