v0.4.0: TUI differentiator visualization — gate trace, rule counter, focus map
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 2s

Gate trace: cognitive-verify accumulates (:gate name :result status) for
each deterministic gate. Trace prepended to action plist via list*.
TUI on-daemon-msg extracts :gate-trace and stores on message object.
add-msg accepts &key gate-trace for future rendering (collapsible Tab).

Rule counter: TUI actuator enriches response payload with :rule-count
=(hash-table-count *hitl-pending*). TUI status bar shows 'Rules:N'.

Focus map: TUI actuator adds :foveal-id from signal context. TUI stores
in state and renders second status line '[Focus: id]'.

Status bar: now two lines — line 1 (connection, mode, msgs, scroll,
rules, thinking spinner), line 2 (focus map, timestamp).

Test: 112/0 across 14 suites (reason 15/0 including gate-trace assertions)
This commit is contained in:
2026-05-06 19:26:06 -04:00
parent 385a6497ac
commit a0f7bd7671
10 changed files with 90 additions and 38 deletions

View File

@@ -21,12 +21,17 @@
(register-actuator :tool #'action-tool-execute)
(register-actuator :tui (lambda (action context)
(declare (ignore context))
(let* ((meta (getf action :meta))
(stream (getf meta :reply-stream)))
(when (and stream (open-stream-p stream))
(format stream "~a" (frame-message action))
(finish-output stream))))))
(declare (ignore context))
(let* ((meta (getf action :meta))
(stream (getf meta :reply-stream)))
(when (and stream (open-stream-p stream))
;; Enrich response with differentiator visualization data
(setf (getf (getf action :payload) :rule-count)
(hash-table-count *hitl-pending*))
(setf (getf (getf action :payload) :foveal-id)
(getf context :foveal-id))
(format stream "~a" (frame-message action))
(finish-output stream))))))
(defun action-dispatch (action context)
"Route an approved action to its registered actuator."

View File

@@ -122,29 +122,36 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(let ((current-action (copy-tree proposed-action))
(approval-needed nil)
(approval-action nil)
(gates nil))
(gates nil)
(gate-trace nil))
;; Collect gates sorted by priority (highest first)
(maphash (lambda (name skill)
(declare (ignore name))
(when (skill-deterministic-fn skill)
(push (cons (skill-priority skill) (skill-deterministic-fn skill)) gates)))
(push (cons (skill-priority skill) (cons (skill-name skill) (skill-deterministic-fn skill))) gates)))
*skill-registry*)
(setf gates (sort gates #'> :key #'car))
(dolist (gate-pair gates)
(let ((result (funcall (cdr gate-pair) current-action context)))
(dolist (gate-entry gates)
(let* ((gate-name (cadr gate-entry))
(result (funcall (cddr gate-entry) current-action context)))
(cond
((eq (getf result :level) :approval-required)
(push (list :gate (or gate-name (car gate-entry)) :result :approval) gate-trace)
(setf approval-needed t
approval-action (getf (getf result :payload) :action)))
((member (getf result :type) '(:LOG :EVENT))
(return-from cognitive-verify result))
(push (list :gate (or gate-name (car gate-entry)) :result :blocked) gate-trace)
(return-from cognitive-verify
(list* :gate-trace (nreverse gate-trace) result)))
((and (listp result) result)
(push (list :gate (or gate-name (car gate-entry)) :result :passed) gate-trace)
(setf current-action result)))))
(if approval-needed
(list :type :EVENT :level :approval-required
:gate-trace (nreverse gate-trace)
:payload (list :sensor :approval-required
:action approval-action))
current-action)))
(list* :gate-trace (nreverse gate-trace) current-action))))
(defun loop-gate-reason (signal)
(let* ((type (proto-get signal :type))
@@ -226,7 +233,9 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello")))
(signal '(:type :EVENT :payload (:sensor :user-input)))
(result (cognitive-verify candidate signal)))
(is (equal candidate result))))
(is (eq :REQUEST (getf result :type)))
(is (equal (getf candidate :payload) (getf result :payload)))
(is (getf result :gate-trace))))
(test test-cognitive-verify-empty-registry
"Contract 1: with no gates registered, action passes through unchanged."
@@ -234,7 +243,8 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls")))
(signal '(:type :EVENT :payload (:sensor :user-input)))
(result (cognitive-verify candidate signal)))
(is (equal candidate result))))
(is (eq :REQUEST (getf result :type)))
(is (equal (getf candidate :payload) (getf result :payload)))))
(test test-cognitive-verify-approval-required
"Contract 1: gate returning :approval-required produces an approval event."

View File

@@ -182,10 +182,15 @@
(defun on-daemon-msg (msg)
(let* ((payload (getf msg :payload))
(text (getf payload :text))
(action (getf payload :action)))
(action (getf payload :action))
(gate-trace (getf msg :gate-trace))
(rule-count (getf payload :rule-count))
(foveal-id (getf payload :foveal-id)))
(when rule-count (setf (st :rule-count) rule-count))
(when foveal-id (setf (st :foveal-id) foveal-id))
(cond
(text (setf (st :busy) nil)
(add-msg :agent text))
(add-msg :agent text :gate-trace gate-trace))
((eq action :handshake)
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
(t (add-msg :agent (format nil "~a" msg))))))

View File

@@ -59,8 +59,8 @@
(setf (st :input-buffer) (reverse (coerce new 'list)))
(setf (st :cursor-pos) (1- pos))))))
(defun add-msg (role content)
(vector-push-extend (list :role role :content content :time (now)) (st :messages))
(defun add-msg (role content &key gate-trace)
(vector-push-extend (list :role role :content content :time (now) :gate-trace gate-trace) (st :messages))
(setf (st :dirty) (list t t nil)))
(defun queue-event (ev)

View File

@@ -4,13 +4,19 @@
(clear win)
(box win 0 0)
(add-string win
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a~a"
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a"
(if (st :connected) "● Connected" "○ Disconnected")
(string-upcase (string (st :mode)))
(length (st :messages))
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0")
(or (st :rule-count) 0)
(if (st :busy) " …thinking" ""))
:y 1 :x 1 :fgcolor (theme-color (if (st :connected) :connected :disconnected)))
;; Second line: Focus map
(let ((focus-info (or (st :foveal-id) "")))
(when (and focus-info (> (length focus-info) 0))
(add-string win (format nil " [Focus: ~a]" focus-info)
:y 2 :x 1 :fgcolor (theme-color :timestamp))))
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor (theme-color :timestamp))
(refresh win))

View File

@@ -76,12 +76,17 @@ Because a skill's deterministic gate runs during Reason, but between Reason and
(register-actuator :tool #'action-tool-execute)
(register-actuator :tui (lambda (action context)
(declare (ignore context))
(let* ((meta (getf action :meta))
(stream (getf meta :reply-stream)))
(when (and stream (open-stream-p stream))
(format stream "~a" (frame-message action))
(finish-output stream))))))
(declare (ignore context))
(let* ((meta (getf action :meta))
(stream (getf meta :reply-stream)))
(when (and stream (open-stream-p stream))
;; Enrich response with differentiator visualization data
(setf (getf (getf action :payload) :rule-count)
(hash-table-count *hitl-pending*))
(setf (getf (getf action :payload) :foveal-id)
(getf context :foveal-id))
(format stream "~a" (frame-message action))
(finish-output stream))))))
#+end_src
#+end_src

View File

@@ -273,29 +273,36 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(let ((current-action (copy-tree proposed-action))
(approval-needed nil)
(approval-action nil)
(gates nil))
(gates nil)
(gate-trace nil))
;; Collect gates sorted by priority (highest first)
(maphash (lambda (name skill)
(declare (ignore name))
(when (skill-deterministic-fn skill)
(push (cons (skill-priority skill) (skill-deterministic-fn skill)) gates)))
(push (cons (skill-priority skill) (cons (skill-name skill) (skill-deterministic-fn skill))) gates)))
*skill-registry*)
(setf gates (sort gates #'> :key #'car))
(dolist (gate-pair gates)
(let ((result (funcall (cdr gate-pair) current-action context)))
(dolist (gate-entry gates)
(let* ((gate-name (cadr gate-entry))
(result (funcall (cddr gate-entry) current-action context)))
(cond
((eq (getf result :level) :approval-required)
(push (list :gate (or gate-name (car gate-entry)) :result :approval) gate-trace)
(setf approval-needed t
approval-action (getf (getf result :payload) :action)))
((member (getf result :type) '(:LOG :EVENT))
(return-from cognitive-verify result))
(push (list :gate (or gate-name (car gate-entry)) :result :blocked) gate-trace)
(return-from cognitive-verify
(list* :gate-trace (nreverse gate-trace) result)))
((and (listp result) result)
(push (list :gate (or gate-name (car gate-entry)) :result :passed) gate-trace)
(setf current-action result)))))
(if approval-needed
(list :type :EVENT :level :approval-required
:gate-trace (nreverse gate-trace)
:payload (list :sensor :approval-required
:action approval-action))
current-action)))
(list* :gate-trace (nreverse gate-trace) current-action))))
#+end_src
** Reason Gate (Stage 2)
@@ -403,7 +410,9 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello")))
(signal '(:type :EVENT :payload (:sensor :user-input)))
(result (cognitive-verify candidate signal)))
(is (equal candidate result))))
(is (eq :REQUEST (getf result :type)))
(is (equal (getf candidate :payload) (getf result :payload)))
(is (getf result :gate-trace))))
(test test-cognitive-verify-empty-registry
"Contract 1: with no gates registered, action passes through unchanged."
@@ -411,7 +420,8 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls")))
(signal '(:type :EVENT :payload (:sensor :user-input)))
(result (cognitive-verify candidate signal)))
(is (equal candidate result))))
(is (eq :REQUEST (getf result :type)))
(is (equal (getf candidate :payload) (getf result :payload)))))
(test test-cognitive-verify-approval-required
"Contract 1: gate returning :approval-required produces an approval event."

View File

@@ -210,10 +210,15 @@ Event handlers + daemon I/O + main loop.
(defun on-daemon-msg (msg)
(let* ((payload (getf msg :payload))
(text (getf payload :text))
(action (getf payload :action)))
(action (getf payload :action))
(gate-trace (getf msg :gate-trace))
(rule-count (getf payload :rule-count))
(foveal-id (getf payload :foveal-id)))
(when rule-count (setf (st :rule-count) rule-count))
(when foveal-id (setf (st :foveal-id) foveal-id))
(cond
(text (setf (st :busy) nil)
(add-msg :agent text))
(add-msg :agent text :gate-trace gate-trace))
((eq action :handshake)
(add-msg :system (format nil "Connected v~a" (getf payload :version))))
(t (add-msg :agent (format nil "~a" msg))))))

View File

@@ -82,8 +82,8 @@ All state mutation flows through event handlers in the controller.
(setf (st :input-buffer) (reverse (coerce new 'list)))
(setf (st :cursor-pos) (1- pos))))))
(defun add-msg (role content)
(vector-push-extend (list :role role :content content :time (now)) (st :messages))
(defun add-msg (role content &key gate-trace)
(vector-push-extend (list :role role :content content :time (now) :gate-trace gate-trace) (st :messages))
(setf (st :dirty) (list t t nil)))
#+end_src

View File

@@ -26,13 +26,19 @@ State is read via ~(st :key)~ — no mutation here.
(clear win)
(box win 0 0)
(add-string win
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a~a"
(format nil " Passepartout ~a [~a] msgs:~a scroll:~a Rules:~a~a"
(if (st :connected) "● Connected" "○ Disconnected")
(string-upcase (string (st :mode)))
(length (st :messages))
(if (> (st :scroll-offset) 0) (format nil "~a↑" (st :scroll-offset)) "0")
(or (st :rule-count) 0)
(if (st :busy) " …thinking" ""))
:y 1 :x 1 :fgcolor (theme-color (if (st :connected) :connected :disconnected)))
;; Second line: Focus map
(let ((focus-info (or (st :foveal-id) "")))
(when (and focus-info (> (length focus-info) 0))
(add-string win (format nil " [Focus: ~a]" focus-info)
:y 2 :x 1 :fgcolor (theme-color :timestamp))))
(add-string win (format nil " ~a" (now)) :y 2 :x 1 :fgcolor (theme-color :timestamp))
(refresh win))
#+end_src