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