passepartout/lisp/core-loop-act.lisp

(in-package :passepartout)

(defvar *actuator-default* :cli
  "The actuator used when no explicit target is specified.")

(defvar *actuator-silent* '(:cli :system-message :emacs)
  "List of actuators that don't generate tool-output feedback.")

(defun actuator-initialize ()
  "Register core actuators and load configuration."
  (let ((def (uiop:getenv "DEFAULT_ACTUATOR"))
        (silent (uiop:getenv "SILENT_ACTUATORS")))
    (when def
      (setf *actuator-default* (intern (string-upcase def) :keyword)))
    (when silent
      (setf *actuator-silent*
            (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword))
                    (uiop:split-string silent :separator '(#\,))))))

  (register-actuator :system #'action-system-execute)
  (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))))))

(defun action-dispatch (action context)
  "Route an approved action to its registered actuator."
  (let ((payload (proto-get action :payload)))
    (when (eq (proto-get payload :sensor) :heartbeat)
      (return-from action-dispatch nil))

    (when (and action (listp action))
      (let* ((meta (proto-get context :meta))
             (source (proto-get meta :source))
             (raw-target (or (proto-get action :target) source *actuator-default*))
             (target (intern (string-upcase (string raw-target)) :keyword))
             (actuator-fn (gethash target *actuator-registry*)))
        (when (and meta (null (getf action :meta)))
          (setf (getf action :meta) meta))
        (if actuator-fn
            (funcall actuator-fn action context)
            (log-message "ACT ERROR: No actuator registered for '~s'" target))))))

(defun action-system-execute (action context)
  "Execute internal harness commands."
  (declare (ignore context))
  (let* ((payload (getf action :payload))
         (cmd (getf payload :action)))
    (case cmd
      (:eval
       (eval (read-from-string (getf payload :code))))
      (:message
       (log-message "ACT [System]: ~a" (getf payload :text)))
      (t
       (log-message "ACT ERROR [System]: Unknown command '~s'" cmd)))))

(defun action-tool-execute (action context)
  "Execute a registered cognitive tool."
  (let* ((payload (getf action :payload))
         (tool-name (getf payload :tool))
         (tool-args (getf payload :args))
         (depth (getf context :depth 0))
         (meta (getf context :meta))
         (source (getf meta :source))
         (tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
    (if tool
        (handler-case
            (let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
                   (result (funcall (cognitive-tool-body tool) clean-args)))
              (when source
                (action-dispatch (list :TYPE :REQUEST :TARGET source 
                                       :PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name result)))
                                context))
              (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
                    :PAYLOAD (list :SENSOR :tool-output :RESULT result :TOOL tool-name)))
          (error (c)
            (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
                  :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c)))))
        (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
              :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name))))))

(defun tool-result-format (tool-name result)
  "Format a tool result for display."
  (if (listp result)
      (let ((status (getf result :status))
            (content (getf result :content))
            (msg (getf result :message)))
        (cond
          ((and (eq status :success) content) (format nil "~a" content))
          ((and (eq status :error) msg) (format nil "ERROR [~a]: ~a" tool-name msg))
          (t (format nil "TOOL [~a] RESULT: ~s" tool-name result))))
      (format nil "TOOL [~a] RESULT: ~a" tool-name result)))

;; Alias: act-gate → loop-gate-act
(defun act-gate (signal)
  (loop-gate-act signal))

(defun loop-gate-act (signal)
  "Final stage of the metabolic pipeline: Actuation.
For approval-required actions, creates a Flight Plan instead of executing."
  (let* ((approved (getf signal :approved-action))
         (signal-status (getf signal :status))
         (type (getf signal :type))
         (meta (getf signal :meta))
         (source (getf meta :source))
         (feedback nil))
    ;; HITL: if the approved action requires human approval,
    ;; create a Flight Plan (Emacs) and HITL entry (all gateways).
    (when (and approved
               (eq (getf approved :level) :approval-required))
      (let* ((payload (getf approved :payload))
             (blocked-action (getf payload :action))
             (hitl (hitl-create blocked-action)))
        (log-message "ACT: Action requires approval — creating Flight Plan + HITL (~a)" (getf hitl :token))
        (dispatcher-flight-plan-create blocked-action)
        (setf (getf signal :status) :suspended)
        (action-dispatch (list :target source
                               :payload (list :text (getf hitl :message)))
                         signal)
        (setf approved nil)
        (setf feedback nil)))
    (when approved
      (let* ((original-type (getf approved :type))
             (verified (cognitive-verify approved signal)))
        (if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT))
                 (not (eq (getf verified :level) :approval-required))
                 (not (member original-type '(:LOG :EVENT))))
            (progn
              (log-message "ACT BLOCKED: Action failed last-mile deterministic check.")
              (setf (getf signal :approved-action) nil)
              (setf feedback verified))
            (progn
              (setf (getf signal :approved-action) verified)
              (setf approved verified)))))

    (case type
      (:REQUEST (action-dispatch signal signal))
      (:LOG (action-dispatch signal signal))
      (:EVENT
       (if approved
           (let* ((target (getf approved :target))
                  (result (action-dispatch approved signal)))
             (cond
               ((and (listp result) (member (getf result :type) '(:EVENT :LOG)))
                (setf feedback result))
               ((and result (not (member target *actuator-silent*)))
                (setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta
                                    :payload (list :sensor :tool-output :result result :tool approved))))))
           (when source (action-dispatch signal signal)))))
    (setf (getf signal :status) :acted)
    feedback))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :fiveam :silent t))

(defpackage :passepartout-pipeline-act-tests
  (:use :cl :fiveam :passepartout)
  (:export #:pipeline-act-suite))

(in-package :passepartout-pipeline-act-tests)

(def-suite pipeline-act-suite :description "Test suite for Act pipeline")
(in-suite pipeline-act-suite)

(test test-loop-gate-act-basic
  (clrhash passepartout::*skill-registry*)
  (let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello"))))
          (result (loop-gate-act signal)))
    (is (eq :acted (getf signal :status)))
    (is (null result))))