summaryrefslogtreecommitdiff
path: root/starling/minibuffer.scm
blob: 690445f294c5d9df629f2924119e27831a39f7e6 (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
;;; 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-thunk make-hash-table)
  (scene-mux #:getter scene-mux #:init-keyword #:scene-mux)
  (overlay-scene #:accessor overlay-scene)
  (user-text #:accessor user-text #:init-form ""))

(define (minibuffer-commands)
  (class-slot-ref <minibuffer> 'commands))

(define-method (add-minibuffer-command name thunk)
  (hash-set! (minibuffer-commands) name thunk))

(define-method (open-minibuffer minibuffer)
  (set! (overlay-scene minibuffer) (current-scene (scene-mux minibuffer)))
  (push-scene (scene-mux minibuffer) minibuffer))

(define-method (close-minibuffer (minibuffer <minibuffer>))
  (pop-scene (scene-mux minibuffer)))

(define-method (run-command (minibuffer <minibuffer>))
  (let ((thunk (hash-ref (minibuffer-commands) (user-text minibuffer))))
    (when (procedure? thunk)
      (modify-user-text minibuffer "")
      (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 (hash-fold (lambda (key value prev)
                        (if (string-prefix? prefix key)
                            (cons key prev)
                            prev))
                      '()
                      (minibuffer-commands))
      ((name)
       (modify-user-text minibuffer name))
      (_ #f))))

(define-method (on-boot (minibuffer <minibuffer>))
  (let* ((res (resolution (car (cameras 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
                                     (vec2-x res)
                                     (+ line-height (* padding 2.0)))
                 #:color (make-color 0.0 0.0 0.0 0.7))
               (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 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)))