Amr Gharbeia
a027e9d984
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 2s
- *memory* → *memory-store* (context, perceive tests, defpackage export) - *skills-registry* → *skill-registry* (context, reason) - *logs-lock* → *log-lock*, *system-logs* → *log-buffer* (context → defpackage) - *cognitive-tools* → *cognitive-tool-registry* (act) - deterministic-verify → cognitive-verify (act → reason) These were runtime errors — referenced variables that don't exist. Harmless until called, but would crash if those code paths were hit.
171 lines
8.4 KiB
Common Lisp
171 lines
8.4 KiB
Common Lisp
(in-package :passepartout)
|
|
|
|
(defvar *backend-registry* (make-hash-table :test 'equal))
|
|
|
|
(defvar *provider-cascade* nil)
|
|
|
|
(defvar *model-selector* nil)
|
|
|
|
(defvar *consensus-enabled* nil)
|
|
|
|
(defun backend-register (name fn)
|
|
(setf (gethash name *backend-registry*) fn))
|
|
|
|
(defun backend-cascade-call (prompt &key
|
|
(system-prompt "You are the Probabilistic engine.")
|
|
(cascade nil)
|
|
(context nil))
|
|
(let ((backends (or cascade *provider-cascade*)))
|
|
(or (dolist (backend backends)
|
|
(let ((backend-fn (gethash backend *backend-registry*)))
|
|
(when backend-fn
|
|
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
|
|
(let* ((model (when *model-selector*
|
|
(funcall *model-selector* backend context)))
|
|
(result (if model
|
|
(funcall backend-fn prompt system-prompt :model model)
|
|
(funcall backend-fn prompt system-prompt))))
|
|
(cond ((and (listp result) (eq (getf result :status) :success))
|
|
(return (getf result :content)))
|
|
((stringp result)
|
|
(return result))
|
|
(t
|
|
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
|
|
backend (getf result :message))))))))
|
|
(list :type :LOG
|
|
:payload (list :text "Neural Cascade Failure: All providers exhausted.")))))
|
|
|
|
(defun markdown-strip (text)
|
|
(if (and text (stringp text))
|
|
(let ((cleaned text))
|
|
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
|
(setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
|
|
(setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
|
|
(string-trim '(#\Space #\Newline #\Tab) cleaned))
|
|
text))
|
|
|
|
(defun plist-keywords-normalize (plist)
|
|
(when (listp plist)
|
|
(loop for (k v) on plist by #'cddr
|
|
collect (if (and (symbolp k) (not (keywordp k)))
|
|
(intern (string k) :keyword)
|
|
k)
|
|
collect v)))
|
|
|
|
(defun think (context)
|
|
(let* ((active-skill (find-triggered-skill context))
|
|
(tool-belt (generate-tool-belt-prompt))
|
|
(global-context (context-assemble-global-awareness))
|
|
(system-logs (context-get-system-logs))
|
|
(assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent"))
|
|
(rejection-trace (proto-get (proto-get context :payload) :rejection-trace))
|
|
(prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
|
|
(raw-prompt (if prompt-generator
|
|
(funcall prompt-generator context)
|
|
(let ((p (proto-get (proto-get context :payload) :text)))
|
|
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
|
|
(reflection-feedback (if rejection-trace
|
|
(format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
|
|
""))
|
|
(skill-augments (let ((augments ""))
|
|
(maphash (lambda (name skill)
|
|
(declare (ignore name))
|
|
(let ((aug-fn (skill-system-prompt-augment skill)))
|
|
(when aug-fn
|
|
(let ((aug-text (ignore-errors (funcall aug-fn context))))
|
|
(when (and aug-text (stringp aug-text) (> (length aug-text) 0))
|
|
(setf augments (concatenate 'string augments aug-text (string #\Newline))))))))
|
|
*skill-registry*)
|
|
(when (> (length augments) 0) augments)))
|
|
(system-prompt (format nil "IDENTITY: ~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a~%~a"
|
|
assistant-name reflection-feedback tool-belt global-context system-logs
|
|
(or skill-augments ""))))
|
|
(let* ((thought (backend-cascade-call raw-prompt :system-prompt system-prompt :context context))
|
|
(cleaned (markdown-strip thought)))
|
|
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
|
|
(handler-case
|
|
(let ((parsed (read-from-string cleaned)))
|
|
(if (listp parsed)
|
|
(plist-keywords-normalize parsed)
|
|
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
|
(error () (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
|
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (if (stringp cleaned) cleaned "No response") :EXPLANATION "Generated by the Probabilistic engine."))))))
|
|
|
|
(defun cognitive-verify (proposed-action context)
|
|
(let ((current-action proposed-action)
|
|
(skills nil))
|
|
(maphash (lambda (name skill)
|
|
(declare (ignore name))
|
|
(when (skill-deterministic-fn skill)
|
|
(push skill skills)))
|
|
*skill-registry*)
|
|
(setf skills (sort skills #'> :key #'skill-priority))
|
|
(dolist (skill skills)
|
|
(let ((trigger (skill-trigger-fn skill))
|
|
(gate (skill-deterministic-fn skill)))
|
|
(when (or (null trigger) (ignore-errors (funcall trigger context)))
|
|
(let ((next-action (funcall gate current-action context)))
|
|
(when (and (listp next-action)
|
|
(member (proto-get next-action :type) '(:LOG :EVENT)))
|
|
(log-message "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill))
|
|
(return-from cognitive-verify next-action))
|
|
(when next-action (setf current-action next-action))))))
|
|
current-action))
|
|
|
|
(defun loop-gate-reason (signal)
|
|
(let* ((type (proto-get signal :type))
|
|
(payload (proto-get signal :payload))
|
|
(sensor (proto-get payload :sensor)))
|
|
(unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message)))
|
|
(return-from loop-gate-reason signal))
|
|
(let ((retries 3)
|
|
(current-signal (copy-tree signal))
|
|
(last-rejection nil))
|
|
(loop
|
|
(when (<= retries 0)
|
|
(setf (getf signal :approved-action) last-rejection)
|
|
(setf (getf signal :status) :reasoned)
|
|
(return signal))
|
|
(when last-rejection
|
|
(setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
|
|
(let ((candidate (think current-signal)))
|
|
(if (and candidate (listp candidate))
|
|
(let ((verified (cognitive-verify candidate current-signal)))
|
|
(if (member (getf verified :type) '(:LOG :EVENT))
|
|
(progn (decf retries) (setf last-rejection verified))
|
|
(progn
|
|
(setf (getf signal :approved-action) verified)
|
|
(setf (getf signal :status) :reasoned)
|
|
(return signal))))
|
|
(progn
|
|
(setf (getf signal :approved-action) nil)
|
|
(setf (getf signal :status) :reasoned)
|
|
(return signal))))))))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-pipeline-reason-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:pipeline-reason-suite))
|
|
|
|
(in-package :passepartout-pipeline-reason-tests)
|
|
|
|
(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline")
|
|
(in-suite pipeline-reason-suite)
|
|
|
|
(test test-decide-gate-safety
|
|
(clrhash passepartout::*skill-registry*)
|
|
(passepartout::defskill :mock-safety
|
|
:priority 50
|
|
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
|
:deterministic (lambda (action ctx)
|
|
(declare (ignore ctx))
|
|
(if (search "rm -rf" (format nil "~s" action))
|
|
(list :type :LOG :payload (list :text "Rejected"))
|
|
action)))
|
|
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /")))
|
|
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
|
(result (cognitive-verify candidate signal)))
|
|
(is (eq :LOG (getf result :type)))))
|