diff --git a/lisp/core-loop-act.lisp b/lisp/core-loop-act.lisp index 3ba6531..9ed3280 100644 --- a/lisp/core-loop-act.lisp +++ b/lisp/core-loop-act.lisp @@ -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." diff --git a/lisp/core-loop-reason.lisp b/lisp/core-loop-reason.lisp index 2762ccb..a897283 100644 --- a/lisp/core-loop-reason.lisp +++ b/lisp/core-loop-reason.lisp @@ -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." diff --git a/lisp/gateway-tui-main.lisp b/lisp/gateway-tui-main.lisp index 14515e9..ba60753 100644 --- a/lisp/gateway-tui-main.lisp +++ b/lisp/gateway-tui-main.lisp @@ -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)))))) diff --git a/lisp/gateway-tui-model.lisp b/lisp/gateway-tui-model.lisp index 715529c..0d81d17 100644 --- a/lisp/gateway-tui-model.lisp +++ b/lisp/gateway-tui-model.lisp @@ -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) diff --git a/lisp/gateway-tui-view.lisp b/lisp/gateway-tui-view.lisp index 1b29bc7..e8fbe3f 100644 --- a/lisp/gateway-tui-view.lisp +++ b/lisp/gateway-tui-view.lisp @@ -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)) diff --git a/org/core-loop-act.org b/org/core-loop-act.org index c47c15a..cd321fc 100644 --- a/org/core-loop-act.org +++ b/org/core-loop-act.org @@ -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 diff --git a/org/core-loop-reason.org b/org/core-loop-reason.org index d5a3ec8..1ca2f93 100644 --- a/org/core-loop-reason.org +++ b/org/core-loop-reason.org @@ -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." diff --git a/org/gateway-tui-main.org b/org/gateway-tui-main.org index eab4748..f63f452 100644 --- a/org/gateway-tui-main.org +++ b/org/gateway-tui-main.org @@ -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)))))) diff --git a/org/gateway-tui-model.org b/org/gateway-tui-model.org index 5cc557f..e114ae0 100644 --- a/org/gateway-tui-model.org +++ b/org/gateway-tui-model.org @@ -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 diff --git a/org/gateway-tui-view.org b/org/gateway-tui-view.org index a2b9c64..3e73d0b 100644 --- a/org/gateway-tui-view.org +++ b/org/gateway-tui-view.org @@ -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