1 files changed, 137 insertions, 0 deletions
diff --git a/catbird/overlay.scm b/catbird/overlay.scm
new file mode 100644
index 0000000..a0563f1
--- /dev/null
+++ b/catbird/overlay.scm
@@ -0,0 +1,137 @@
+;;; Catbird Game Engine
+;;; Copyright © 2022 David Thompson <davet@gnu.org>
+;;;
+;;; Catbird 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.
+;;;
+;;; Catbird 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 Catbird.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; System overlay scene for notifications and developer tools.
+;;
+;;; Code:
+(define-module (catbird overlay)
+  #:use-module (catbird kernel)
+  #:use-module (catbird input-map)
+  #:use-module (catbird minibuffer)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (catbird region)
+  #:use-module (catbird repl)
+  #:use-module (catbird scene)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics path)
+  #:use-module (chickadee graphics text)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (ice-9 format)
+  #:use-module (oop goops)
+  #:export (make-overlay
+            notify
+            open-minibuffer))
+
+(define %background-color (make-color 0.2 0.2 0.2 0.8))
+
+(define-class <overlay> (<scene>))
+
+(define (make-overlay)
+  (make <overlay>))
+
+(define-method (notify (scene <overlay>) message)
+  (run-script scene
+    (let* ((padding 8.0)
+           (label (make <label>
+                    #:name 'message
+                    #:rank 1
+                    #:position (vec2 padding padding)
+                    #:text message))
+           (region (car (regions scene)))
+           (bg (make <canvas>
+                 #:name 'background
+                 #:painter
+                 (with-style ((fill-color %background-color))
+                   (fill
+                    (rounded-rectangle (vec2 0.0 0.0)
+                                       (+ (width label) padding padding)
+                                       (+ (height label) padding)
+                                       #:radius 2.0)))))
+           (notification (make <node-2d>
+                           #:position (vec2 padding
+                                            (- (height (camera region))
+                                               (height bg)
+                                               padding)))))
+      (attach-to notification bg label)
+      (attach-to scene notification)
+      (sleep 5.0)
+      (detach notification))))
+
+(define-method (open-minibuffer)
+  (let ((r (find-region-by-name 'overlay)))
+    (push-major-mode (scene r) (make <minibuffer-mode>))))
+
+(define-class <fps-display> (<node-2d>))
+
+(define-method (on-boot (fps-display <fps-display>))
+  (let* ((font (default-font))
+         (padding 4.0)
+         (box-width (+ (font-line-width font "999.9")
+                       (* padding 2.0)))
+         (box-height (+ (font-line-height font) padding)))
+    (attach-to fps-display
+               (make <canvas>
+                 #:name 'background
+                 #:painter
+                 (with-style ((fill-color (make-color 0 0 0 0.5)))
+                   (fill
+                    (rectangle (vec2 0.0 0.0)
+                               box-width
+                               box-height))))
+               (make <label>
+                 #:name 'label
+                 #:rank 1
+                 #:font font
+                 #:position (vec2 padding padding)))
+    (set! (width fps-display) box-width)
+    (set! (height fps-display) box-height)
+    (set! (origin-y fps-display) box-height)
+    (update-fps fps-display)
+    (run-script fps-display
+      (forever
+       (sleep 1.0)
+       (update-fps fps-display)))))
+
+(define-method (update-fps (fps-display <fps-display>))
+  (set! (text (& fps-display label))
+    (format #f "~1,1f" (frames-per-second))))
+
+(define-minibuffer-command show-fps
+  (let* ((r (find-region-by-name 'overlay))
+         (s (and r (scene r))))
+    (when (and s (not (& s fps-display)))
+      (attach-to s (make <fps-display>
+                     #:name 'fps-display
+                     #:rank 99
+                     #:position (vec2 0.0 (area-height r)))))))
+
+(define-minibuffer-command hide-fps
+  (let* ((r (find-region-by-name 'overlay))
+         (s (and r (scene r)))
+         (f (and s (& s fps-display))))
+    (when f (detach f))))
+
+(define-minibuffer-command repl
+  (let* ((r (find-region-by-name 'overlay))
+         (s (and r (scene r))))
+    (when s
+      (push-major-mode s (make <repl-mode>)))))
+
+(bind-input/global (key-press 'x '(alt)) open-minibuffer)