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/minibuffer.scm | 157 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 157 insertions(+)
 create mode 100644 catbird/minibuffer.scm

(limited to 'catbird/minibuffer.scm')

diff --git a/catbird/minibuffer.scm b/catbird/minibuffer.scm
new file mode 100644
index 0000000..d4ef244
--- /dev/null
+++ b/catbird/minibuffer.scm
@@ -0,0 +1,157 @@
+(define-module (catbird minibuffer)
+  #:use-module (catbird kernel)
+  #:use-module (catbird line-editor)
+  #:use-module (catbird mode)
+  #:use-module (catbird node)
+  #:use-module (catbird node-2d)
+  #:use-module (catbird region)
+  #:use-module (catbird scene)
+  #:use-module (chickadee)
+  #: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 match)
+  #:use-module (oop goops)
+  #:export (<minibuffer>
+            <minibuffer-mode>
+            define-minibuffer-command))
+
+(define %background-color (make-color 0.0 0.0 0.0 0.8))
+(define %prompt "> ")
+(define %padding 8.0)
+
+(define-class <minibuffer> (<node-2d>)
+  (commands #:accessor commands #:allocation #:class
+            #:init-thunk make-hash-table))
+
+(define (minibuffer-commands)
+  (class-slot-ref <minibuffer> 'commands))
+
+(define (lookup-minibuffer-command name)
+  (hash-ref (minibuffer-commands) name))
+
+(define (add-minibuffer-command name thunk)
+  (hash-set! (minibuffer-commands) name thunk))
+
+(define-syntax-rule (define-minibuffer-command name body ...)
+  (add-minibuffer-command (symbol->string 'name) (lambda () body ...)))
+
+(define-method (on-boot (minibuffer <minibuffer>))
+  (attach-to minibuffer
+             (make <canvas>
+               #:name 'background)
+             (make <line-editor>
+               #:name 'editor
+               #:rank 1
+               #:position (vec2 %padding %padding)
+               #:prompt %prompt)))
+
+(define-method (resize-minibuffer (minibuffer <minibuffer>) width)
+  (set! (painter (& minibuffer background))
+        (with-style ((fill-color %background-color))
+          (fill
+           (rectangle (vec2 0.0 0.0)
+                      width
+                      (+ (font-line-height (font (& minibuffer editor)))
+                         (* %padding 2.0)))))))
+
+(define-method (clear-minibuffer (minibuffer <minibuffer>))
+  (clear-line (& minibuffer editor)))
+
+;; TODO: The line editor should have a generic completion facility.
+(define-method (autocomplete (minibuffer <minibuffer>))
+  (let ((prefix (get-line (& minibuffer editor))))
+    ;; Auto-complete if there is a single command name that starts
+    ;; with the characters the user has already typed.
+    (match (hash-fold (lambda (key value prev)
+                        (if (string-prefix? prefix key)
+                            (cons key prev)
+                            prev))
+                      '()
+                      (minibuffer-commands))
+      ((name)
+       (overwrite (& minibuffer editor) name))
+      ;; TODO: Display multiple completion options to user.
+      (_ #f))))
+
+(define-method (get-command (minibuffer <minibuffer>))
+  (lookup-minibuffer-command (get-line (& minibuffer editor))))
+
+(define-method (valid-command? (minibuffer <minibuffer>))
+  (procedure? (get-command minibuffer)))
+
+(define-method (run-command (minibuffer <minibuffer>))
+  (let ((thunk (get-command minibuffer)))
+    (save-to-history (& minibuffer editor))
+    (when (procedure? thunk)
+      (thunk))))
+
+
+;;;
+;;; Minibuffer major mode
+;;;
+
+(define-class <minibuffer-mode> (<major-mode>)
+  (prev-keyboard-focus #:accessor prev-keyboard-focus))
+
+(define-method (on-enter (mode <minibuffer-mode>))
+  (let* ((scene (parent mode))
+         (region (car (regions scene)))
+         (minibuffer (or (& scene minibuffer)
+                         (make <minibuffer>
+                           #:name 'minibuffer
+                           #:rank 999))))
+    (if (parent minibuffer)
+        (begin
+          (clear-minibuffer minibuffer)
+          (show (& scene minibuffer)))
+        (attach-to (parent mode) minibuffer))
+    (resize-minibuffer minibuffer (area-width region))
+    (set! (prev-keyboard-focus mode) (current-keyboard-focus))
+    (take-keyboard-focus region)
+    (add-minor-mode scene (make <line-edit-mode>
+                            #:editor (& scene minibuffer editor)))))
+
+(define-method (on-exit (mode <minibuffer-mode>))
+  (hide (& (parent mode) minibuffer))
+  (remove-minor-mode (parent mode) <line-edit-mode>)
+  (take-keyboard-focus (prev-keyboard-focus mode)))
+
+(define-method (close-minibuffer (mode <minibuffer-mode>))
+  (pop-major-mode (parent mode)))
+
+(define-method (autocomplete (mode <minibuffer-mode>))
+  (autocomplete (& (parent mode) minibuffer)))
+
+(define-method (run-command (mode <minibuffer-mode>))
+  ;; The minibuffer needs to be closed before running the command so
+  ;; that this mode is no longer active and we've had a chance to
+  ;; clean up the state of the overlay scene.
+  (let ((minibuffer (& (parent mode) minibuffer)))
+    (when (valid-command? minibuffer)
+      (close-minibuffer mode)
+      (run-command minibuffer))))
+
+(bind-input <minibuffer-mode> (key-press 'escape) close-minibuffer)
+(bind-input <minibuffer-mode> (key-press 'g '(ctrl)) close-minibuffer)
+(bind-input <minibuffer-mode> (key-press 'tab) autocomplete)
+(bind-input <minibuffer-mode> (key-press 'return) run-command)
+
+
+;;;
+;;; Basic minibuffer commands
+;;;
+
+(define (for-each-user-scene proc)
+  (for-each (lambda (region)
+              (unless (eq? (name region) 'overlay)
+                (let ((s (scene region)))
+                  (and s (proc s)))))
+            (all-regions)))
+
+;; General purpose built-in commands.
+(define-minibuffer-command pause (for-each-user-scene pause))
+(define-minibuffer-command resume (for-each-user-scene resume))
+(define-minibuffer-command quit (exit-catbird))
-- 
cgit v1.2.3