summaryrefslogtreecommitdiff
path: root/catbird/line-editor.scm
diff options
context:
space:
mode:
Diffstat (limited to 'catbird/line-editor.scm')
-rw-r--r--catbird/line-editor.scm312
1 files changed, 312 insertions, 0 deletions
diff --git a/catbird/line-editor.scm b/catbird/line-editor.scm
new file mode 100644
index 0000000..74ced0b
--- /dev/null
+++ b/catbird/line-editor.scm
@@ -0,0 +1,312 @@
+(define-module (catbird line-editor)
+ #:use-module (catbird mode)
+ #:use-module (catbird node)
+ #:use-module (catbird node-2d)
+ #:use-module (catbird observer)
+ #:use-module (catbird region)
+ #:use-module (catbird ring-buffer)
+ #: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)
+ #:use-module (srfi srfi-1)
+ #:export (<line-editor>
+ <line-edit-mode>
+ backward-char
+ backward-delete-char
+ forward-delete-char
+ backward-history
+ beginning-of-line
+ clear-line
+ end-of-line
+ forward-char
+ forward-history
+ get-line
+ history-enabled?
+ insert-char
+ invert-color
+ kill-line
+ overwrite
+ prompt
+ save-to-history)
+ #:re-export (color
+ font))
+
+;; TODO: Matching paren/quote highlighting.
+(define-class <line-editor> (<node-2d>)
+ (chars-before #:accessor chars-before #:init-value '())
+ (chars-after #:accessor chars-after #:init-value '())
+ (cached-line #:accessor cached-line #:init-value #f)
+ (prompt #:accessor prompt #:init-keyword #:prompt #:init-value ""
+ #:observe? #t)
+ ;; TODO: Allow customizable history length.
+ (history #:accessor history #:init-form (make-ring-buffer 128))
+ (history-enabled? #:accessor history-enabled?
+ #:init-keyword #:history-enabled? #:init-value #t)
+ (history-index #:accessor history-index #:init-value 0)
+ (font #:accessor font #:init-keyword #:font #:init-thunk default-font
+ #:asset? #t)
+ (color #:accessor color #:init-keyword #:color #:init-value white)
+ (invert-color #:accessor invert-color #:init-keyword #:invert-color
+ #:init-value black)
+ (accepting-input? #:accessor accepting-input? #:init-value #t))
+
+(define-method (on-change (editor <line-editor>) slot old new)
+ (update-visual editor))
+
+(define-method (on-boot (editor <line-editor>))
+ (attach-to editor
+ (make <label>
+ #:name 'prompt
+ #:font (font editor)
+ #:text (prompt editor)
+ #:color (color editor))
+ (make <label>
+ #:name 'before-cursor
+ #:rank 1
+ #:font (font editor)
+ #:color (color editor))
+ (make <label>
+ #:name 'on-cursor
+ #:rank 1
+ #:font (font editor))
+ (make <label>
+ #:name 'after-cursor
+ #:rank 1
+ #:font (font editor)
+ #:color (color editor))
+ (make <canvas>
+ #:name 'cursor
+ #:painter
+ (with-style ((fill-color (color editor)))
+ (fill
+ (rectangle (vec2 0.0 0.0)
+ (font-line-width (font editor) "_")
+ (font-line-height (font editor)))))))
+ (discard-next-char editor)
+ (update-visual editor))
+
+;; Whenever a command key sequence is pressed while the line editor is
+;; active we have to stop accepting text input for one tick.
+;; Otherwise, an errant character shows up. For example, if the user
+;; presses alt+p, and that is bound to (backward-history editor 1),
+;; the 'p' character shows up at the end of the line. This is due to
+;; the fact that SDL generates a key event *and* an input event for
+;; the same key press.
+(define-method (discard-next-char (editor <line-editor>))
+ (run-script editor
+ (set! (accepting-input? editor) #f)
+ (sleep (current-timestep))
+ (set! (accepting-input? editor) #t)))
+
+(define-method (update-visual (editor <line-editor>))
+ (let* ((lprompt (& editor prompt))
+ (cursor (& editor cursor))
+ (before (& editor before-cursor))
+ (on (& editor on-cursor))
+ (after (& editor after-cursor)))
+ (set! (cached-line editor) #f)
+ ;; Stop cursor blink. The cursor should only blink when the user
+ ;; is idle.
+ (stop-scripts cursor)
+ ;; Ensure the cursor is visible in case we stopped the script
+ ;; during a time when it was hidden.
+ (show cursor)
+ ;; Put the proper text in the proper labels
+ (set! (text lprompt) (prompt editor))
+ (set! (text before)
+ (list->string (reverse (chars-before editor))))
+ (set! (text on)
+ (match (chars-after editor)
+ (() "")
+ ((c . _)
+ (string c))))
+ (set! (text after)
+ (match (chars-after editor)
+ (() "")
+ ((_ . chars)
+ (list->string chars))))
+ ;; Line everything up.
+ (place-right lprompt before)
+ (place-right before on)
+ (place-right on after)
+ (align-left on cursor)
+ ;; Adjust size
+ (set! (width editor)
+ (+ (width lprompt) (width before) (width on) (width after)))
+ (set! (height editor) (height cursor))
+ ;; Resume blinking cursor after a short idle timeout.
+ (run-script cursor
+ (forever
+ (set! (color on) (invert-color editor))
+ (sleep 0.5)
+ (hide cursor)
+ (set! (color on) (color editor))
+ (sleep 0.5)
+ (show cursor)))))
+
+(define-method (get-line (editor <line-editor>))
+ (or (cached-line editor)
+ (let ((line (list->string
+ (append (reverse (chars-before editor))
+ (chars-after editor)))))
+ (set! (cached-line editor) line)
+ line)))
+
+(define-method (overwrite (editor <line-editor>) str)
+ (set! (chars-before editor) (reverse (string->list str)))
+ (set! (chars-after editor) '())
+ (update-visual editor))
+
+(define-method (clear-line (editor <line-editor>))
+ (discard-next-char editor)
+ (overwrite editor "")
+ (newest-history editor))
+
+(define-method (insert-char (editor <line-editor>) char)
+ (when (accepting-input? editor)
+ (set! (chars-before editor) (cons char (chars-before editor)))
+ (update-visual editor)))
+
+(define-method (backward-delete-char (editor <line-editor>) n)
+ (unless (<= n 0)
+ (set! (chars-before editor)
+ (drop (chars-before editor)
+ (min n (length (chars-before editor))))))
+ (discard-next-char editor)
+ (update-visual editor))
+
+(define-method (forward-delete-char (editor <line-editor>) n)
+ (unless (<= n 0)
+ (set! (chars-after editor)
+ (drop (chars-after editor)
+ (min n (length (chars-after editor))))))
+ (discard-next-char editor)
+ (update-visual editor))
+
+(define-method (kill-line (editor <line-editor>))
+ (forward-delete-char editor (length (chars-after editor))))
+
+(define-method (backward-char (editor <line-editor>) n)
+ (let loop ((n n)
+ (before (chars-before editor))
+ (after (chars-after editor)))
+ (if (or (<= n 0) (null? before))
+ (begin
+ (set! (chars-before editor) before)
+ (set! (chars-after editor) after))
+ (loop (- n 1)
+ (cdr before)
+ (cons (car before) after))))
+ (discard-next-char editor)
+ (update-visual editor))
+
+(define-method (forward-char (editor <line-editor>) n)
+ (let loop ((n n)
+ (before (chars-before editor))
+ (after (chars-after editor)))
+ (if (or (<= n 0) (null? after))
+ (begin
+ (set! (chars-before editor) before)
+ (set! (chars-after editor) after))
+ (loop (- n 1)
+ (cons (car after) before)
+ (cdr after))))
+ (discard-next-char editor)
+ (update-visual editor))
+
+(define-method (beginning-of-line (editor <line-editor>))
+ (backward-char editor (length (chars-before editor))))
+
+(define-method (end-of-line (editor <line-editor>))
+ (forward-char editor (length (chars-after editor))))
+
+(define-method (save-to-history (editor <line-editor>))
+ (ring-buffer-put! (history editor) (get-line editor)))
+
+(define-method (history-ref (editor <line-editor>) i)
+ (ring-buffer-ref (history editor) i))
+
+(define-method (go-to-history (editor <line-editor>) i)
+ (when (and (history-enabled? editor)
+ (>= i 0)
+ (< i (ring-buffer-length (history editor))))
+ (set! (history-index editor) i)
+ (overwrite editor (history-ref editor i))))
+
+(define-method (backward-history (editor <line-editor>) n)
+ (discard-next-char editor)
+ (go-to-history editor (max (- (history-index editor) n) 0)))
+
+(define-method (forward-history (editor <line-editor>) n)
+ (discard-next-char editor)
+ (go-to-history editor
+ (min (+ (history-index editor) n)
+ (- (ring-buffer-length (history editor)) 1))))
+
+(define-method (newest-history (editor <line-editor>))
+ (set! (history-index editor) (ring-buffer-length (history editor))))
+
+
+;;;
+;;; Line editing minor mode
+;;;
+
+(define-class <line-edit-mode> (<minor-mode>)
+ (editor #:accessor editor #:init-keyword #:editor))
+
+(define-method (insert-text (mode <line-edit-mode>) new-text)
+ (let ((e (editor mode)))
+ (string-for-each (lambda (char)
+ (insert-char e char))
+ new-text)))
+
+(define-method (backward-delete-char (mode <line-edit-mode>))
+ (backward-delete-char (editor mode) 1))
+
+(define-method (forward-delete-char (mode <line-edit-mode>))
+ (forward-delete-char (editor mode) 1))
+
+(define-method (backward-char (mode <line-edit-mode>))
+ (backward-char (editor mode) 1))
+
+(define-method (forward-char (mode <line-edit-mode>))
+ (forward-char (editor mode) 1))
+
+(define-method (beginning-of-line (mode <line-edit-mode>))
+ (beginning-of-line (editor mode)))
+
+(define-method (end-of-line (mode <line-edit-mode>))
+ (end-of-line (editor mode)))
+
+(define-method (backward-history (mode <line-edit-mode>))
+ (backward-history (editor mode) 1))
+
+(define-method (forward-history (mode <line-edit-mode>))
+ (forward-history (editor mode) 1))
+
+(define-method (kill-line (mode <line-edit-mode>))
+ (kill-line (editor mode)))
+
+(bind-input <line-edit-mode> (key-press 'backspace) backward-delete-char)
+(bind-input <line-edit-mode> (key-press 'delete) forward-delete-char)
+(bind-input <line-edit-mode> (key-press 'd '(ctrl)) forward-delete-char)
+(bind-input <line-edit-mode> (key-press 'left) backward-char)
+(bind-input <line-edit-mode> (key-press 'b '(ctrl)) backward-char)
+(bind-input <line-edit-mode> (key-press 'right) forward-char)
+(bind-input <line-edit-mode> (key-press 'f '(ctrl)) forward-char)
+(bind-input <line-edit-mode> (key-press 'home) beginning-of-line)
+(bind-input <line-edit-mode> (key-press 'a '(ctrl)) beginning-of-line)
+(bind-input <line-edit-mode> (key-press 'end) end-of-line)
+(bind-input <line-edit-mode> (key-press 'e '(ctrl)) end-of-line)
+(bind-input <line-edit-mode> (key-press 'up) backward-history)
+(bind-input <line-edit-mode> (key-press 'p '(alt)) backward-history)
+(bind-input <line-edit-mode> (key-press 'down) forward-history)
+(bind-input <line-edit-mode> (key-press 'n '(alt)) forward-history)
+(bind-input <line-edit-mode> (key-press 'k '(ctrl)) kill-line)
+(bind-input <line-edit-mode> (text-input) insert-text)