Add very simple minibuffer a la Emacs.

3 files changed, 154 insertions, 4 deletions

diff --git a/Makefile.am b/Makefile.am
index 503a280..cad01a9 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -45,6 +45,7 @@ SOURCES = 					\
   starling/node.scm				\
   starling/scene.scm				\
   starling/repl.scm				\
+  starling/minibuffer.scm			\
   starling/kernel.scm				\
   starling/node-2d.scm				\
   starling/transition.scm
diff --git a/starling/kernel.scm b/starling/kernel.scm
index 25b6917..042e1ac 100644
--- a/starling/kernel.scm
+++ b/starling/kernel.scm
@@ -40,6 +40,7 @@
   #:use-module (starling config)
   #:use-module (starling node)
   #:use-module (starling repl)
+  #:use-module (starling minibuffer)
   #:use-module (starling scene)
   #:use-module (starling system)
   #:use-module ((sdl2 video) #:prefix sdl2:)
@@ -118,10 +119,15 @@
 (define-method (on-key-press (kernel <kernel>) key scancode modifiers repeat?)
   ;; Hot keys when in dev mode
   (when developer-mode?
-    (match key
-      ('f5 (reboot-current-scene))
-      ('escape (abort-game))
-      (_ #t)))
+    (unless (& kernel minibuffer)
+      (match key
+        ('x
+         (when (or (memq 'left-alt modifiers)
+                   (memq 'right-alt modifiers))
+           (unless (& kernel minibuffer)
+             (open-minibuffer kernel))))
+        ('escape (abort-game))
+        (_ #t))))
   (next-method))
 
 (define-method (update-tree (kernel <kernel>) dt)
@@ -304,6 +310,16 @@ kernel.  A convenient procedure for developers."
   (display "rebooting\n")
   (reboot (current-scene (current-kernel))))
 
+(define (pause-current-scene)
+  (pause (current-scene (current-kernel))))
+
+(define (resume-current-scene)
+  (resume (current-scene (current-kernel))))
+
+(add-minibuffer-command "reboot" reboot-current-scene)
+(add-minibuffer-command "pause" pause-current-scene)
+(add-minibuffer-command "resume" resume-current-scene)
+
 (define-meta-command ((debug-game lisparuga) repl)
   "debug-game
 Enter a debugger for the current game loop error."
diff --git a/starling/minibuffer.scm b/starling/minibuffer.scm
new file mode 100644
index 0000000..ed2761b
--- /dev/null
+++ b/starling/minibuffer.scm
@@ -0,0 +1,133 @@
+;;; Starling Game Engine
+;;; Copyright © 2020 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 Starling.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Minibuffer for fast code execution.
+;;
+;;; Code:
+
+(define-module (starling minibuffer)
+  #:use-module (chickadee graphics color)
+  #:use-module (chickadee graphics font)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:use-module (starling node)
+  #:use-module (starling node-2d)
+  #:use-module (starling scene)
+  #:export (<minibuffer>
+            add-minibuffer-command
+            open-minibuffer))
+
+(define-class <minibuffer> (<scene-2d>)
+  (commands #:accessor commands #:allocation #:class #:init-form '())
+  (scene-mux #:getter scene-mux #:init-keyword #:scene-mux)
+  (overlay-scene #:getter overlay-scene #:init-keyword #:overlay-scene)
+  (user-text #:accessor user-text #:init-form ""))
+
+(define (minibuffer-commands)
+  (class-slot-ref <minibuffer> 'commands))
+
+(define-method (add-minibuffer-command name thunk)
+  (class-slot-set! <minibuffer> 'commands
+                   (cons (cons name thunk)
+                         (minibuffer-commands))))
+
+(define-method (open-minibuffer scene-mux)
+  (let ((minibuffer (make <minibuffer>
+                      #:name 'minibuffer
+                      #:scene-mux scene-mux
+                      #:overlay-scene (current-scene scene-mux))))
+    ;; We need to delay the minibuffer by one frame so that the text
+    ;; input event for the "x" character (part of the M-x key
+    ;; shortcut) is not processed by the minibuffer, thus adding an
+    ;; "x" to the user text entry area before the user has actually
+    ;; typed anything.
+    (run-script scene-mux
+      (sleep 1)
+      (push-scene scene-mux minibuffer))))
+
+(define-method (close-minibuffer (minibuffer <minibuffer>))
+  (pop-scene (scene-mux minibuffer)))
+
+(define-method (run-command (minibuffer <minibuffer>))
+  (let ((thunk (assoc-ref (minibuffer-commands) (user-text minibuffer))))
+    (when (procedure? thunk)
+      (close-minibuffer minibuffer)
+      (thunk))))
+
+(define-method (modify-user-text (minibuffer <minibuffer>) new-text)
+  (set! (user-text minibuffer) new-text)
+  (set! (text (& minibuffer text-entry))
+    (string-append "> " new-text)))
+
+(define-method (backward-delete (minibuffer <minibuffer>))
+  (let ((text (user-text minibuffer)))
+    (modify-user-text minibuffer
+                      (substring text 0 (max (- (string-length text) 1) 0)))))
+
+(define-method (tab-complete (minibuffer <minibuffer>))
+  (let ((prefix (user-text minibuffer)))
+    ;; Auto-complete if there is a single command name that starts
+    ;; with the characters the user has already typed.
+    (match (filter-map (match-lambda
+                         ((name . _)
+                          (and (string-prefix? prefix name) name)))
+                       (minibuffer-commands))
+      ((name)
+       (modify-user-text minibuffer name))
+      (_ #f))))
+
+(define-method (on-boot (minibuffer <minibuffer>))
+  (let* ((view-area (area (car (views minibuffer))))
+         (font (default-font))
+         (line-height (font-line-height font))
+         (padding 8.0))
+    (attach-to minibuffer
+               (make <filled-rect>
+                 #:region (make-rect 0.0 0.0
+                                     (rect-width view-area)
+                                     (+ line-height (* padding 2.0)))
+                 #:color (make-color 0.0 0.0 0.0 1.0))
+               (make <label>
+                 #:name 'text-entry
+                 #:rank 9
+                 #:font font
+                 #:position (vec2 padding padding)))
+    (modify-user-text minibuffer "")))
+
+(define-method (update (minibuffer <minibuffer>) dt)
+  (update-tree (overlay-scene minibuffer) dt)
+  (next-method))
+
+(define-method (render (minibuffer <minibuffer>) alpha)
+  (render-tree (overlay-scene minibuffer) alpha)
+  (next-method))
+
+(define-method (on-key-press (minibuffer <minibuffer>) key scancode modifiers repeat?)
+  (match key
+    ('escape (close-minibuffer minibuffer))
+    ('return (run-command minibuffer))
+    ('backspace (backward-delete minibuffer))
+    ('tab (tab-complete minibuffer))
+    (_ #f)))
+
+(define-method (on-text-input (minibuffer <minibuffer>) text)
+  (modify-user-text minibuffer (string-append (user-text minibuffer) text)))