1 files changed, 63 insertions, 0 deletions
diff --git a/apple-town-fair/time-display.scm b/apple-town-fair/time-display.scm
new file mode 100644
index 0000000..c36618f
--- /dev/null
+++ b/apple-town-fair/time-display.scm
@@ -0,0 +1,63 @@
+;;; 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 time-display)
+  #: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 graphics path)
+  #:use-module (chickadee math vector)
+  #:use-module (oop goops)
+  #:export (<time-display>))
+
+(define-class <time-display> (<node-2d>)
+  (day #:accessor day #:init-keyword #:day #:init-value 0 #:observe? #t)
+  (time #:accessor time #:init-keyword #:time #:init-value 0 #:observe? #t))
+
+(define-method (on-boot (t <time-display>))
+  (attach-to t
+             (make <canvas>
+               #:name 'background)
+             (make <label>
+               #:name 'day
+               #:font monogram-font)
+             (make <label>
+               #:name 'time
+               #:font monogram-font))
+  (refresh t))
+
+(define-method (refresh (t <time-display>))
+  (let ((padding 4.0))
+    (set! (text (& t day)) (day->string (day t)))
+    (set! (text (& t time)) (time->string (time t)))
+    (set! (position-x (& t day)) padding)
+    (set! (position-x (& t time)) padding)
+    (set! (position-y (& t time)) padding)
+    (place-above (& t time) (& t day) #:padding padding)
+    (set! (width t) (+ (max (width (& t day)) (width (& t time)))
+                       (* padding 2.0)))
+    (set! (height t) (+ (height (& t day))
+                        (height (& t time))
+                        (* padding 3.0)))
+    (unless (painter (& t background))
+      (set! (painter (& t background))
+            (with-style ((fill-color (make-color 1.0 0.0 0.0 0.25)))
+              (fill
+               (rectangle (vec2 0.0 0.0) (width t) (height t))))))))
+
+(define-method (on-change (t <time-display>) slot old new)
+  (refresh t))