blob: 1435bfd5c4c730ec120953dc6d53ba73c5c46a13 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;; Commentary:
;;
;; Emacs-like minibuffer for command entry.
;;
;;; Code:
(define-module (catbird minibuffer)
#:use-module (catbird kernel)
#:use-module (catbird line-editor)
#:use-module (catbird mixins)
#: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 (initialize (minibuffer <minibuffer>) initargs)
(next-method)
(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)
(let ((bg (& minibuffer background)))
(set! (painter bg)
(with-style ((fill-color %background-color))
(fill
(rectangle (vec2 0.0 0.0)
width
(+ (font-line-height (font (& minibuffer editor)))
(* %padding 2.0))))))
(resize bg)))
(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 (abort-game))
|
