passepartout/org/channel-tui.org

#+TITLE: Passepartout TUI
#+PROPERTY: header-args:lisp :tangle ../lisp/channel-tui.lisp

* TUI

Direct-rendering TUI using cl-tty backend + framebuffer. Layout by
~compute-layout~. Three zones: status (3 lines), chat, input.

#+begin_src lisp :tangle ../lisp/channel-tui.lisp
(in-package :cl-user)

(ql:quickload :cl-tty :silent t)
(ql:quickload :passepartout :silent t)
(ql:quickload :usocket :silent t)
(ql:quickload :bordeaux-threads :silent t)

(defpackage :passepartout.tui
  (:use :cl :cl-tty.backend :cl-tty.input :cl-tty.rendering :cl-tty.layout)
  (:export #:tui-main))
(in-package :passepartout.tui)

(defvar *messages* (make-array 0 :fill-pointer 0 :adjustable t))
(defvar *daemon-stream* nil)
(defvar *event-queue* nil)
(defvar *event-lock* (bt:make-lock "tui-event"))
(defvar *streaming-text* nil)
(defvar *input-buf* nil)
(defvar *cursor-pos* 0)
(defvar *connected* nil)
(defvar *running* t)

;; Input
(defun input-insert-char (ch)
  (let ((pos *cursor-pos*))
    (setf *input-buf* (concatenate 'list (subseq *input-buf* 0 pos) (list ch)
                                   (subseq *input-buf* pos)))
    (incf *cursor-pos*)))

(defun input-delete-char ()
  (when (and *input-buf* (> *cursor-pos* 0))
    (setf *input-buf* (nconc (subseq *input-buf* 0 (1- *cursor-pos*))
                              (subseq *input-buf* *cursor-pos*)))
    (decf *cursor-pos*)))

(defun input-string () (coerce (reverse *input-buf*) 'string))

(defun input-submit ()
  (let ((text (string-trim '(#\Space) (input-string))))
    (when (> (length text) 0)
      (vector-push-extend (list :role :user :content text) *messages*)
      (send-daemon `(:type :event :payload (:sensor :user-input :text ,text)))
      (setf *input-buf* nil *cursor-pos* 0))))

;; Daemon
(defun send-daemon (msg)
  (let ((s *daemon-stream*))
    (when (and s (open-stream-p s))
      (handler-case
          (let ((str (prin1-to-string msg)))
            (format s "~6,'0X~A" (length str) str)
            (finish-output s))
        (error () nil)))))

(defun connect-daemon (&optional (host "127.0.0.1") (port 9105))
  (handler-case
      (let ((s (usocket:socket-connect host port :timeout 5)))
        (setf *daemon-stream* (usocket:socket-stream s) *connected* t)
        (bt:make-thread (lambda () (reader-loop)) :name "tui-reader")
        (vector-push-extend '(:role :system :content "* Connected *") *messages*))
    (error (c)
      (vector-push-extend (list :role :system :content
                                (format nil "* Connection failed: ~A *" c))
                          *messages*))))

(defun reader-loop ()
  (loop while *running*
        for msg = (handler-case
                      (let* ((hdr (make-string 6)) (n 0))
                        (loop while (< n 6)
                              do (let ((ch (read-char *daemon-stream* nil)))
                                   (unless ch (return-from reader-loop nil))
                                   (setf (char hdr n) ch) (incf n)))
                        (let* ((len (parse-integer hdr :radix 16 :junk-allowed t))
                               (buf (make-string (or len 0))))
                          (when (and len (> len 0))
                            (loop for i from 0 below len
                                  do (let ((ch (read-char *daemon-stream* nil)))
                                       (unless ch (return-from reader-loop nil))
                                       (setf (char buf i) ch)))
                            (let ((*read-eval* nil)) (read-from-string buf)))))
                    (error () nil))
        if msg do (bt:with-lock-held (*event-lock*) (push msg *event-queue*))
        else do (sleep 0.5)))

;; Render
(defun render-frame (fb w h)
  (backend-clear fb)
  (let ((fg (if *connected* "#00FF00" "#FF4444")))
    (draw-text fb 1 1
      (format nil " Passepartout  ~a  [CHAT]  msgs:~d"
              (if *connected* "● Connected" "○ Disconnected")
              (length *messages*))
      fg nil)
    (draw-text fb 1 2 " Ctrl+P: palette  Ctrl+Q: quit  /help: help" "#888888" nil))
  (let ((y 4))
    (loop for i from (1- (length *messages*)) downto 0
          for msg = (aref *messages* i)
          do (let* ((role (getf msg :role))
                    (content (getf msg :content))
                    (fg (case role (:user "#00FF00") (:agent "#FFFFFF")
                                 (:system "#FFFF00") (t "#888888")))
                    (pfx (case role (:user "> ") (:agent "  ") (:system "* ") (t "  ")))))
               (draw-text fb 1 y (concatenate 'string pfx content) fg nil)
               (incf y))
          (when (> y (- h 3)) (loop-finish))))
  (draw-text fb 1 (- h 1) (concatenate 'string "> " (input-string)) "#FFFFFF" "#0F3460"))

;; Event loop
(defun tui-main ()
  (setf *running* t *messages* (make-array 0 :fill-pointer 0 :adjustable t))
  (connect-daemon)
  (with-raw-terminal
    (with-terminal (be w h)
      (let ((prev-fb (make-framebuffer w h))
            (curr-fb (make-framebuffer w h)))
        (loop while *running* do
          (bt:with-lock-held (*event-lock*)
            (dolist (msg (nreverse *event-queue*))
              (let* ((payload (getf msg :payload)) (text (getf payload :text))
                     (type (getf msg :type)))
                (cond
                  ((and (eq type :stream-chunk) text (not (string= text "")))
                   (if *streaming-text*
                       (setf *streaming-text* (concatenate 'string *streaming-text* text))
                       (setf *streaming-text* text
                             *messages* (let ((v (make-array (1+ (length *messages*))
                                               :fill-pointer (1+ (length *messages*))
                                               :adjustable t)))
                                         (loop for i below (length *messages*)
                                               do (setf (aref v i) (aref *messages* i)))
                                         (setf (aref v (length *messages*))
                                               (list :role :thinking :content text))
                                         v))))
                  ((and (eq type :stream-chunk) (string= text ""))
                   (setf *streaming-text* nil))
                  (text
                   (vector-push-extend (list :role :agent :content text) *messages*)))))
            (setf *event-queue* nil))
          (multiple-value-bind (type data) (read-event be :timeout 0)
            (declare (ignore type))
            (when (key-event-p data)
              (let ((k (key-event-key data)))
                (cond
                  ((eq k :escape) (when *streaming-text* (setf *streaming-text* nil)))
                  ((eq k :enter) (input-submit))
                  ((eq k :backspace) (input-delete-char))
                  ((eq k :left) (when (> *cursor-pos* 0) (decf *cursor-pos*)))
                  ((eq k :right) (when (< *cursor-pos* (length *input-buf*))
                                   (incf *cursor-pos*)))
                  ((eq k :ctrl-u) (setf *input-buf* nil *cursor-pos* 0))
                  ((eq k :ctrl-a) (setf *cursor-pos* 0))
                  ((eq k :ctrl-e) (setf *cursor-pos* (length *input-buf*)))
                  ((eq k :ctrl-d) (when (null *input-buf*) (setf *running* nil)))
                  ((eq k :ctrl-q) (setf *running* nil))
                  (t (let ((chr (when (keywordp k)
                                   (let ((s (string k)))
                                     (when (= (length s) 1) (char-downcase (char s 0)))))))
                       (when chr (input-insert-char chr))))))))
          (render-frame curr-fb w h)
          (flush-framebuffer prev-fb curr-fb be)
          (rotatef prev-fb curr-fb)
          (sleep 0.05))))))
#+end_src