summaryrefslogtreecommitdiff
path: root/catbird/overlay.scm
diff options
context:
space:
mode:
Diffstat (limited to 'catbird/overlay.scm')
-rw-r--r--catbird/overlay.scm116
1 files changed, 116 insertions, 0 deletions
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)