passepartout/harness/act.lisp

(in-package :opencortex)

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

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

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

  (register-actuator :system #'execute-system-action)
  (register-actuator :tool #'execute-tool-action)

  (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 dispatch-action (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 dispatch-action 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 *default-actuator*))
             (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)
            (harness-log "ACT ERROR: No actuator registered for '~s'" target))))))

(defun execute-system-action (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
       (harness-log "ACT [System]: ~a" (getf payload :text)))
      (t
       (harness-log "ACT ERROR [System]: Unknown command '~s'" cmd)))))

(defun execute-tool-action (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-tools*)))
    (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
                (dispatch-action (list :TYPE :REQUEST :TARGET source 
                                       :PAYLOAD (list :ACTION :MESSAGE :TEXT (format-tool-result 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 format-tool-result (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)))

(defun act-gate (signal)
  "Final stage of the metabolic pipeline: Actuation."
  (let* ((approved (getf signal :approved-action))
         (type (getf signal :type))
         (meta (getf signal :meta))
         (source (getf meta :source))
         (feedback nil))
    (when approved
      (let* ((original-type (getf approved :type))
             (verified (deterministic-verify approved signal)))
        (if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) (not (member original-type '(:LOG :EVENT))))
            (progn
              (harness-log "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 (dispatch-action signal signal))
      (:LOG (dispatch-action signal signal))
      (:EVENT
       (if approved
           (let* ((target (getf approved :target))
                  (result (dispatch-action approved signal)))
             (cond
               ((and (listp result) (member (getf result :type) '(:EVENT :LOG)))
                (setf feedback result))
               ((and result (not (member target *silent-actuators*)))
                (setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta
                                    :payload (list :sensor :tool-output :result result :tool approved))))))
           (when source (dispatch-action signal signal)))))
    (setf (getf signal :status) :acted)
    feedback))