From 14464dee966fe415d4c8e1fb8b5205653b22003f Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 3 Oct 2022 19:22:23 -0400
Subject: Add prototype catbird modules.

---
 catbird/overlay.scm | 116 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 116 insertions(+)
 create mode 100644 catbird/overlay.scm

(limited to 'catbird/overlay.scm')

diff --git a/catbird/overlay.scm b/catbird/overlay.scm
new file mode 100644
index 0000000..31a1442
--- /dev/null
+++ b/catbird/overlay.scm
@@ -0,0 +1,116 @@
+(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)
-- 
cgit v1.2.3