From 14464dee966fe415d4c8e1fb8b5205653b22003f Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Mon, 3 Oct 2022 19:22:23 -0400
Subject: Add prototype catbird modules.

---
 catbird/line-editor.scm | 312 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 312 insertions(+)
 create mode 100644 catbird/line-editor.scm

(limited to 'catbird/line-editor.scm')

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)
-- 
cgit v1.2.3