feat(v0.2.0): Self-Improvement & Structural Integrity
Some checks failed
Deploy-Agent-V15-Stdin / JOB-V15-STDIN (push) Failing after 8s

- Fix critical paren balance issues across harness/skills.org, act.org,
  loop.org, memory.org, and skills/self-edit|emacs-edit.org
- Add :reload-skill cognitive tool for hot-reloading without restart
- Add :generate-embeddings tool and self-edit hot-reload infrastructure
- Wire all new skills (self-edit, emacs-edit, lisp-utils) into main ASDF
- Regenerate all .lisp tangled files via emacs --batch org-babel-tangle
- Add :opencortex/tests ASDF system with 14 test suites
- Fix test files to compile cleanly (self-edit-tests symbol vis, etc.)
This commit is contained in:
2026-04-27 07:30:01 -04:00
parent 1e202629ce
commit 43dbe3cf2d
29 changed files with 1980 additions and 590 deletions

View File

@@ -262,7 +262,7 @@ Example feedback chain:
:DEPTH (1+ depth)
:META meta
:PAYLOAD (list :SENSOR :tool-error
:MESSAGE (format nil "Tool '~a' not found" tool-name)))))
:MESSAGE (format nil "Tool '~a' not found" tool-name))))))
#+end_src
** format-tool-result: Human-Readable Output

View File

@@ -202,7 +202,7 @@ The heartbeat thread ensures the agent remains alive even without external input
:payload (list :sensor :heartbeat
:unix-time (get-universal-time)))))
:name "opencortex-heartbeat"))))
:name "opencortex-heartbeat")))))
#+end_src
* Main Entry Point

View File

@@ -202,12 +202,7 @@ These tests verify the Memory system. Run with:
(let* ((ast-v2 '(:type :HEADLINE :properties (:ID "cow-node" :TITLE "State B") :contents nil))
(id-v2 (ingest-ast ast-v2))
(hash-v2 (org-object-hash (lookup-object id-v2))))
(is (equal (org-object-hash (lookup-object "cow-node")) hash-v2))
(rollback-memory 0)
(is (equal (org-object-hash (lookup-object "cow-node")) hash-v1))
(is (not (null (gethash hash-v2 *history-store*))))))
#+end_src
** Disk Persistence (save-memory / load-memory)
Essential for surviving crashes. Saves the in-memory hash tables to disk and loads them back on restart. The path is controlled by the `MEMORY_SNAPSHOT_PATH` environment variable.
@@ -445,7 +440,7 @@ Following the Engineering Standards, the Memory must be empirically verified thr
(let* ((ast-v1 '(:type :HEADLINE :properties (:ID "cow-node" :TITLE "State A") :contents nil))
(id-v1 (ingest-ast ast-v1))
(hash-v1 (org-object-hash (lookup-object id-v1))))
;; Take a snapshot at State A
(snapshot-memory)
@@ -463,7 +458,7 @@ Following the Engineering Standards, the Memory must be empirically verified thr
(is (equal (org-object-hash (lookup-object "cow-node")) hash-v1))
;; Verify State B is still safely in the history store (no data loss)
(is (not (null (gethash hash-v2 *history-store*))))))
(is (not (null (gethash hash-v2 *history-store*)))))))
(test merkle-hash-consistency
"Verify that identical ASTs produce identical Merkle hashes."
@@ -486,6 +481,6 @@ Following the Engineering Standards, the Memory must be empirically verified thr
(let* ((ast-mod '(:type :HEADLINE :properties (:ID "root" :TITLE "Root")
:contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Changed") :contents nil))))
(id-mod (progn (clrhash *memory*) (ingest-ast ast-mod)))
(mod-hash (org-object-hash (lookup-object id-mod))))
(mod-hash (org-object-hash (lookup-object id-mod))))
(is (not (equal root-hash mod-hash))))))
#+end_src

View File

@@ -195,9 +195,9 @@ Only loads blocks that specify a .lisp tangle target, ignoring tests and example
(search ".lisp" tl)
(not (search "tests/" tl))
(not (search "test/" tl))))))
((uiop:string-prefix-p "#+end_src" (string-downcase clean-line))
(setf in-lisp-block nil)
(setf collect-this-block nil))
((uiop:string-prefix-p "#+end" (string-downcase clean-line))
(setf in-lisp-block nil)
(setf collect-this-block nil))
((and in-lisp-block collect-this-block)
(unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line))
(uiop:string-prefix-p ":END:" (string-upcase clean-line)))
@@ -394,7 +394,7 @@ EXAMPLES:
(let ((base-name (pathname-name file)))
(setf (skill-entry-status (gethash base-name *skill-catalog*)) :ready)
(format nil "OK: Skill '~a' reloaded successfully." base-name))
(format nil "ERROR: Reload failed with status ~a" status)))))))))
(format nil "ERROR: Reload failed with status ~a" status))))))))))
#+end_src
*** The File Read Tool (V 0.2.0 File I/O)
@@ -413,7 +413,7 @@ EXAMPLES:
(handler-case
(uiop:read-file-string file)
(error (c)
(format nil "ERROR reading ~a: ~a" file c)))))
(format nil "ERROR reading ~a: ~a" file c))))))
#+end_src
*** The File Write Tool (V 0.2.0 File I/O)
@@ -445,7 +445,7 @@ EXAMPLES:
(if append-p "content appended" "file written")
file))
(error (c)
(format nil "ERROR writing ~a: ~a" file c)))))
(format nil "ERROR writing ~a: ~a" file c))))))
#+end_src
*** The String Replace Tool (V 0.2.0 File I/O)
@@ -476,7 +476,7 @@ EXAMPLES:
(format nil "OK: Replaced first occurrence in ~a" file))
(format nil "ERROR: Pattern not found in ~a" file))))
(error (c)
(format nil "ERROR replacing in ~a: ~a" file c)))))
(format nil "ERROR replacing in ~a: ~a" file c))))))
#+end_src
* Test Suite

View File

@@ -1,22 +1,47 @@
(in-package :opencortex)
(defvar *default-actuator* :cli)
(defvar *silent-actuators* '(:cli :system-message :emacs))
(defvar *default-actuator* :cli
"The actuator used when no explicit target is specified.
Override with DEFAULT_ACTUATOR environment variable.")
(defvar *silent-actuators* '(:cli :system-message :emacs)
"List of actuators that don't generate tool-output feedback.
These typically have their own feedback mechanisms (CLI prints directly, etc.)")
(defun initialize-actuators ()
"Loads actuator routing defaults from environment variables and registers core harness actuators."
"Load actuator configuration from environment and register core actuators.
Environment variables:
- DEFAULT_ACTUATOR: Keyword for default target (:cli, :shell, etc.)
- SILENT_ACTUATORS: Comma-separated list of actuators that skip feedback
Registers three core actuators:
1. :system - Internal commands (eval, create-skill, message)
2. :tool - Cognitive tool execution
3. :tui - Terminal UI output via reply stream"
;; Load environment configuration
(let ((def (uiop:getenv "DEFAULT_ACTUATOR"))
(silent (uiop:getenv "SILENT_ACTUATORS")))
;; Set default actuator
(when def
(setf *default-actuator* (intern (string-upcase def) "KEYWORD")))
(setf *default-actuator*
(intern (string-upcase def) "KEYWORD")))
;; Parse silent actuators list
(when silent
(setf *silent-actuators*
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) "KEYWORD"))
(mapcar (lambda (s)
(intern (string-upcase (string-trim '(#\Space) s))
"KEYWORD"))
(str:split "," silent)))))
;; Register core harness actuators
(register-actuator :system #'execute-system-action)
(register-actuator :tool #'execute-tool-action)
;; TUI actuator: sends response back through the reply stream
(register-actuator :tui (lambda (action context)
(let* ((meta (getf context :meta))
(stream (getf meta :reply-stream)))
@@ -25,55 +50,107 @@
(finish-output stream))))))
(defun dispatch-action (action context)
"Route an approved action to its registered actuator.
ACTION is a plist with structure:
(:TYPE :REQUEST :TARGET :shell :PAYLOAD (...))
CONTEXT is the signal being processed (for metadata access)
The target is resolved in order of priority:
1. Explicit :target in the action
2. :source from the original signal's metadata
3. *default-actuator* configuration variable
Returns the actuator's result (may be a feedback signal or NIL)."
(let ((payload (proto-get action :payload)))
;; Heartbeats don't generate actuation
(when (eq (proto-get payload :sensor) :heartbeat)
(return-from dispatch-action nil)))
"Routes an approved action to its registered physical actuator."
(when (and action (listp action))
(let* ((meta (proto-get context :meta))
(source (proto-get meta :source))
(raw-target (or (ignore-errors (getf action :TARGET))
(ignore-errors (getf action :target))
source
*default-actuator*))
(target (intern (string-upcase (string raw-target)) :keyword))
(actuator-fn (gethash target *actuator-registry*)))
;; Ensure outbound action has meta if context had it
(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 for ~s (from ~s)" target raw-target)))))
(return-from dispatch-action nil))
(when (and action (listp action))
(let* ((meta (proto-get context :meta))
(source (proto-get meta :source))
(raw-target (or (ignore-errors (getf action :TARGET))
(ignore-errors (getf action :target))
source
*default-actuator*))
(target (intern (string-upcase (string raw-target)) :keyword))
(actuator-fn (gethash target *actuator-registry*)))
;; Preserve metadata in outbound action
(when (and meta (null (getf action :meta)))
(setf (getf action :meta) meta))
;; Execute or log error
(if actuator-fn
(funcall actuator-fn action context)
(harness-log "ACT ERROR: No actuator registered for '~s' (requested by ~s)"
target raw-target))))))
(defun execute-system-action (action context)
"Processes internal harness commands. (ACTUATOR)"
(declare (ignore context))
(let* ((payload (ignore-errors (getf action :payload)))
(cmd (ignore-errors (getf payload :action))))
(case cmd
(:eval (let ((code (getf payload :code)))
(eval (read-from-string code))))
(:create-skill (let* ((filename (getf payload :filename)) (content (getf payload :content))
(skills-dir (merge-pathnames "skills/" (asdf:system-source-directory :opencortex)))
(full-path (merge-pathnames filename skills-dir)))
(with-open-file (out full-path :direction :output :if-exists :supersede) (write-string content out))
(load-skill-from-org full-path)))
(:message (harness-log "ACT [System]: ~a" (getf payload :text)))
(t (harness-log "ACT ERROR [System]: Unknown command ~s" cmd)))))
"Execute internal harness commands.
(defun format-tool-result (tool-name result)
"Intelligently formats a tool result for user 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)))
This actuator handles meta-commands that affect the harness itself,
rather than external side effects. Commands include:
- :eval - Evaluate arbitrary Lisp code (DANGEROUS, validate first!)
- :create-skill - Write a new skill org file and reload
- :message - Log a message to the harness log
These commands bypass the normal actuator system since they operate
on the harness internals rather than external systems."
(declare (ignore context))
(let* ((payload (ignore-errors (getf action :payload)))
(cmd (ignore-errors (getf payload :action))))
(case cmd
;; Evaluate Lisp code - guarded by lisp-validator skill
(:eval
(let ((code (getf payload :code)))
(eval (read-from-string code))))
;; Create and load a new skill from content
(:create-skill
(let* ((filename (getf payload :filename))
(content (getf payload :content))
(skills-dir (merge-pathnames "skills/"
(asdf:system-source-directory :opencortex)))
(full-path (merge-pathnames filename skills-dir)))
(with-open-file (out full-path
:direction :output
:if-exists :supersede)
(write-string content out))
(load-skill-from-org full-path)))
;; Log an informational message
(:message
(harness-log "ACT [System]: ~a" (getf payload :text)))
;; Unknown command
(t
(harness-log "ACT ERROR [System]: Unknown command '~s'" cmd)))))
(defun execute-tool-action (action context)
"Executes a registered cognitive tool. (ACTUATOR)"
"Execute a registered cognitive tool.
Tools are registered functions with:
- A guard function (optional, for safety checks)
- A body function (the actual implementation)
- Metadata (description, parameter specs)
This actuator:
1. Looks up the tool by name
2. Runs the guard function (if present)
3. Executes the body function with parsed arguments
4. Returns a feedback signal with the result
The feedback mechanism allows tool results to trigger further reasoning."
(let* ((payload (getf action :payload))
(tool-name (getf payload :tool))
(tool-args (getf payload :args))
@@ -81,78 +158,156 @@
(meta (getf context :meta))
(source (getf meta :source))
(tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
(when tool
;; Tool Permission Gate: Check permission before execution
(let ((permission (check-tool-permission-gate tool-name context)))
(when (eq permission :deny)
(return-from execute-tool-action
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
:PAYLOAD (list :SENSOR :tool-error :tool tool-name :message (format nil "Tool PERMISSION DENIED: ~a" tool-name))))))
(when (listp permission)
(return-from execute-tool-action
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
:PAYLOAD (list :SENSOR :permission-pending :tool tool-name :args tool-args)))))
(handler-case
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
(if tool
(handler-case
;; Parse arguments (handle both flat and nested plists)
(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)))
(let ((feedback (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
:PAYLOAD (list :SENSOR :tool-output :RESULT result :TOOL tool-name))))
;; If we have a source, send a status message with the result, formatted for humans
(when source
(dispatch-action (list :TYPE :REQUEST :TARGET source
:PAYLOAD (list :ACTION :MESSAGE :TEXT (format-tool-result tool-name result)))
context))
feedback))
;; Format result for source
(when source
(dispatch-action (list :TYPE :REQUEST
:TARGET source
:PAYLOAD (list :ACTION :MESSAGE
:TEXT (format-tool-result tool-name result)))
context))
;; Return feedback signal for potential further processing
(list :TYPE :EVENT
:DEPTH (1+ depth)
:META meta
:PAYLOAD (list :SENSOR :tool-output
:RESULT result
:TOOL tool-name)))
;; Tool execution error
(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 "Tool not found"))))
(list :TYPE :EVENT
:DEPTH (1+ depth)
:META meta
:PAYLOAD (list :SENSOR :tool-error
:TOOL tool-name
:MESSAGE (format nil "~a" c)))))
;; Tool not found
(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 human-readable display.
Tools return either:
- A plist: (:status :success :content \"...\") or (:status :error :message \"...\")
- A raw value (string, number, etc.)
This function normalizes both formats into a consistent string presentation."
(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: Actuation and feedback generation."
"Final stage of the metabolic pipeline: Actuation.
This stage has three responsibilities:
1. Last-mile safety check: Run deterministic gates one more time
before execution (handles race conditions, concurrent modifications)
2. Actuation: Dispatch the approved action to its target actuator
3. Feedback generation: If the action produced results, create a
feedback signal that feeds back into the pipeline
Modifies the signal:
- :approved-action - May be modified by last-mile verification
- :status - Set to :acted
Returns a feedback signal if the action produced results, otherwise NIL."
(let* ((approved (getf signal :approved-action))
(type (getf signal :type))
(meta (getf signal :meta))
(source (getf meta :source))
(feedback nil)
;; context must keep internal objects for actuators to function
(context signal))
;; 1. Last-Mile Safety Check (The Bouncer & Deterministic Gates)
;; Step 1: Last-mile deterministic verification
;; This catches any issues that arose between reasoning and acting
(when approved
(let* ((original-type (getf approved :type))
(verified (deterministic-verify approved signal)))
(if (and (listp verified)
;; Check if deterministic verification blocked the action
(if (and (listp verified)
(member (getf verified :type) '(:LOG :EVENT :log :event))
(not (member original-type '(:LOG :EVENT :log :event))))
;; Action was blocked by verification
(progn
(harness-log "ACT BLOCKED: Action failed last-mile deterministic check.")
(setf (getf signal :approved-action) nil)
(setf approved nil)
(setf feedback verified))
;; Action passed verification
(progn
(setf (getf signal :approved-action) verified)
(setf approved verified)))))
;; 2. Actuation Logic
;; Step 2: Actuation based on signal type
(case type
(:REQUEST (dispatch-action signal context))
(:LOG (dispatch-action signal context))
(:EVENT
;; Explicit requests go directly to dispatch
(:REQUEST
(dispatch-action signal context))
;; Log messages also dispatch
(:LOG
(dispatch-action signal context))
;; Events with approved actions dispatch to their target
(:EVENT
(if approved
(let* ((target (getf approved :target))
(result (dispatch-action approved context)))
;; If the actuator returns a signal (like :tool-output), it becomes the feedback.
;; Otherwise, generate tool-output feedback for non-silent actuators.
(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))))))
;; If no approved action but we have a source, this might be a raw event/log stimulus.
;; Determine feedback based on actuator response
(cond
;; Actuator returned a signal - use it as feedback
((and (listp result)
(member (getf result :type) '(:EVENT :LOG)))
(setf feedback result))
;; Non-silent actuator with result - format as tool-output
((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))))))
;; No approved action, but have source - might be raw event
(when source
(dispatch-action signal context)))))
;; Step 3: Update signal status
(setf (getf signal :status) :acted)
feedback))

View File

@@ -42,7 +42,7 @@
(defun context-get-system-logs (&optional limit)
"Retrieves the most recent lines from the harness's internal log."
(let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20)))
(bordeaux-threads:with-lock-held (*logs-lock*)
(bt:with-lock-held (*logs-lock*)
(let ((count (min log-limit (length *system-logs*))))
(subseq *system-logs* 0 count)))))

View File

@@ -1,109 +1,258 @@
(in-package :opencortex)
(defun bouncer-scan-secrets (text)
"Returns the name of the secret found in TEXT, or NIL if clean."
"Scans TEXT for known secrets from the vault.
RETURNS: The name of the matched secret, or NIL if text is clean.
This prevents the catastrophic failure mode where the agent
accidentally echoes an API key in its response or log output.
The check uses substring matching (not regex) for reliability.
Only secrets longer than 5 characters are checked to avoid
false positives on common words."
(when (and text (stringp text))
(let ((found-secret nil))
(maphash (lambda (key val)
;; Only check secrets of meaningful length
(when (and val (stringp val) (> (length val) 5))
;; Search for secret value in action text
(when (search val text)
(setf found-secret key))))
opencortex::*vault-memory*)
found-secret)))
(defvar *bouncer-network-whitelist*
'("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")
"Domains that the Bouncer considers safe for outbound connections.
This whitelist should be minimal—only services explicitly configured
as gateways. All other outbound connections require approval.")
(defun bouncer-check-network-exfil (cmd)
"Returns T if the command appears to target an unwhitelisted external host."
"Detects if CMD attempts to contact an unwhitelisted external host.
Returns T if the command targets an unknown external host.
Returns NIL if the command is clean or only contacts whitelisted hosts.
The check looks for HTTP/HTTPS/FTP URLs and extracts the domain.
If the domain isn't in *bouncer-network-whitelist*, it's flagged."
(when (and cmd (stringp cmd))
;; Basic check for common data exfiltration tools being used with IPs/URLs
(let ((network-whitelist '("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")))
(when (cl-ppcre:scan "(http|https|ftp)://([\\w\\.-]+)" cmd)
(multiple-value-bind (match regs)
(cl-ppcre:scan-to-strings "(http|https|ftp)://([\\w\\.-]+)" cmd)
(declare (ignore match))
(let ((domain (aref regs 1)))
(not (some (lambda (safe) (search safe domain)) network-whitelist))))))))
;; Look for URL patterns in the command
(when (cl-ppcre:scan "(http|https|ftp)://([\\w\\.-]+)" cmd)
(multiple-value-bind (match regs)
(cl-ppcre:scan-to-strings "(http|https|ftp)://([\\w\\.-]+)" cmd)
(declare (ignore match))
(let ((domain (aref regs 1)))
;; Check if domain is whitelisted
(not (some (lambda (safe) (search safe domain))
*bouncer-network-whitelist*)))))))
(defun bouncer-check (action context)
"The 5-Vector security gate. Blocks or queues actions based on risk."
"The 5-Vector security gate for high-risk actions.
Evaluates an action against all security vectors and either:
- Returns the action unchanged (pass)
- Returns a blocking LOG event (hard block)
- Returns an approval-required EVENT (soft block)
Vector evaluation order:
1. Already approved actions pass immediately
2. Secret exposure → hard block
3. Network exfiltration → approval required
4. High-impact targets → approval required
The context parameter is not used directly but provided for
consistency with the skill gate signature."
(declare (ignore context))
(let* ((target (getf action :target))
(payload (getf action :payload))
(text (or (getf payload :text) (getf action :text)))
;; Extract cmd from direct shell or tool-mediated shell call
(cmd (or (getf payload :cmd)
(when (and (eq target :tool) (equal (getf payload :tool) "shell"))
(getf (getf payload :args) :cmd))))
(when (and (eq target :tool)
(equal (getf payload :tool) "shell"))
(getf (getf payload :args) :cmd))))
(approved (getf action :approved)))
(cond
;; 0. Bypass for already approved actions
(approved action)
;; 1. Secret Exposure Vector (Hard Block)
(cond
;; Vector 0: Already approved actions pass through
(approved
action)
;; Vector 1: Secret Exposure (Hard Block)
;; If any vault secret is found in the action text, block immediately
((and text (bouncer-scan-secrets text))
(let ((secret-name (bouncer-scan-secrets text)))
(harness-log "SECURITY VIOLATION: Blocked leak of secret ~a" secret-name)
`(:type :log :payload (:level :error :text ,(format nil "Action blocked: Potential exposure of ~a" secret-name)))))
(harness-log "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
;; 2. Network Exfiltration Vector (Authorization Required)
((and (or (eq target :shell)
(and (eq target :tool) (equal (getf payload :tool) "shell")))
;; Vector 2: Network Exfiltration (Soft Block)
;; Shell commands targeting unknown hosts require approval
((and (or (eq target :shell)
(and (eq target :tool)
(equal (getf payload :tool) "shell")))
(bouncer-check-network-exfil cmd))
(harness-log "SECURITY WARNING: External network call detected. Queuing for approval.")
`(:type :EVENT :payload (:sensor :approval-required :action ,action)))
;; 3. High-Impact Target Vector (Authorization Required)
(list :type :EVENT
:payload (list :sensor :approval-required
:action action)))
;; Vector 3: High-Impact Targets (Soft Block)
;; Shell execution, file repair, and eval require approval
((or (member target '(:shell))
(and (eq target :tool) (member (getf payload :tool) '("shell" "repair-file") :test #'string=))
(and (eq target :EMACS) (eq (getf payload :action) :eval)))
(harness-log "SECURITY: High-impact action ~a requires approval." (or (getf payload :tool) target))
`(:type :EVENT :payload (:sensor :approval-required :action ,action)))
(and (eq target :tool)
(member (getf payload :tool) '("shell" "repair-file") :test #'string=))
(and (eq target :emacs)
(eq (getf payload :action) :eval)))
;; 4. Default Pass
(t action))))
(harness-log "SECURITY: High-impact action requires approval: ~a"
(or (getf payload :tool) target))
(list :type :EVENT
:payload (list :sensor :approval-required
:action action)))
;; Vector 4: Default pass
(t
action))))
(defun bouncer-process-approvals ()
"Scans the object store for APPROVED flight plans and re-injects their actions."
"Scans the object store for APPROVED flight plans and re-injects them.
This function is called on every heartbeat, allowing the agent to
check for approvals without blocking the main signal pipeline.
Flight Plan format:
- Has TAGS including \"FLIGHT_PLAN\"
- Has TODO set to \"APPROVED\"
- Has ACTION containing the serialized action plist
When an approved flight plan is found:
1. Deserialize the action from the ACTION attribute
2. Mark the action as :approved = t (bypasses security gate)
3. Re-inject into the signal pipeline
4. Mark the flight plan as DONE
Returns T if any flight plans were processed."
(let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED"))
(found-any nil))
(dolist (node approved-nodes)
(let* ((tags (getf (org-object-attributes node) :TAGS))
(action-str (getf (org-object-attributes node) :ACTION)))
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str)
(harness-log "BOUNCER: Found approved flight plan ~a. Re-injecting..." (org-object-id node))
;; Only process flight plans (not other APPROVED items)
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal)
action-str)
(harness-log "BOUNCER: Found approved flight plan '~a'. Re-injecting..."
(org-object-id node))
(let ((action (ignore-errors (read-from-string action-str))))
(when action
;; Mark as approved to bypass the gate
;; Mark as approved to bypass the security gate on re-injection
(setf (getf action :approved) t)
;; Re-inject the action into the signal pipeline
(inject-stimulus action)
;; Mark as DONE
;; Mark the flight plan as done
(setf (getf (org-object-attributes node) :TODO) "DONE")
(setq found-any t))))))
found-any))
(defun bouncer-create-flight-plan (blocked-action)
"Creates an Org node representing a pending flight plan for manual approval.
BLOCKED-ACTION is the action plist that was intercepted.
The flight plan node contains:
- A title describing the action
- TODO set to PLAN (awaiting approval)
- TAGS including FLIGHT_PLAN
- ACTION attribute containing the serialized action
The user reviews the flight plan and changes TODO to APPROVED.
On the next heartbeat, bouncer-process-approvals will detect
the approval and re-inject the action.
Returns the generated org-id for the flight plan."
(let ((id (org-id-new)))
(harness-log "BOUNCER: Creating flight plan node '~a'..." id)
;; Inject a node creation request
(list :type :REQUEST
:target :emacs
:payload (list :action :insert-node
:id id
:attributes (list
:TITLE "Flight Plan: High-Risk Action"
:TODO "PLAN"
:TAGS '("FLIGHT_PLAN")
:ACTION (format nil "~s" blocked-action)))))
(defun bouncer-deterministic-gate (action context)
"Main gate for the bouncer skill."
"Main deterministic gate for the Bouncer skill.
Handles three types of signals:
1. :approval-required - Create a flight plan for the blocked action
2. :heartbeat - Process any pending approvals
3. otherwise - Run security check on the action
The trigger is always true (bouncer evaluates all actions)
because security cannot be selective."
(let* ((payload (getf context :payload))
(sensor (getf payload :sensor)))
(case sensor
;; Signal type 1: Action was blocked, create flight plan
(:approval-required
(let* ((blocked-action (getf payload :action))
(id (org-id-new)))
(harness-log "BOUNCER: Creating flight plan node...")
;; Create the node in Emacs (or inbox)
(list :type :REQUEST :target :EMACS :action :insert-node
:id id :attributes `(:TITLE "Flight Plan: High-Risk Action"
:TODO "PLAN"
:TAGS ("FLIGHT_PLAN")
:ACTION ,(format nil "~s" blocked-action)))))
(let* ((blocked-action (getf payload :action)))
(bouncer-create-flight-plan blocked-action)))
;; Signal type 2: Heartbeat, check for approvals
(:heartbeat
;; Periodically check for approvals
(bouncer-process-approvals)
(if action (bouncer-check action context) action))
;; After processing approvals, still run the security check
(if action
(bouncer-check action context)
action))
;; Signal type 3: Normal action, run security check
(otherwise
(if action (bouncer-check action context) action)))))
(if action
(bouncer-check action context)
action)))))
(defskill :skill-bouncer
:priority 150
:trigger (lambda (ctx) t) ;; Bouncer evaluates all actions deterministically
:trigger (lambda (ctx) (declare (ignore ctx)) t)
:probabilistic nil
:deterministic #'bouncer-deterministic-gate)

View File

@@ -8,22 +8,40 @@
(:mentorship . 200)
(:sustainability . 100))
"Priority alist for policy invariant conflict resolution.
Higher numbers take precedence.")
Higher numbers take precedence.
When two invariants conflict, the higher priority wins.
Example: Modularity (250) takes precedence over Mentorship (200),
meaning a change that would fatten the harness is blocked
even if it would be educational.")
(defun policy-check-transparency (action context)
"Ensures the action is inspectable and user-facing actions carry an explanation.
Returns the action if clean, or a blocking LOG event if the action is opaque."
TRANSPARENCY CHECK:
1. Action must be a valid plist (not opaque data)
2. User-facing actions (:cli, :tui, :emacs) must include :explanation
3. Heartbeat and handshake messages are exempt (they're system status)
Returns the action if clean, or a blocking LOG event if violated."
(declare (ignore context))
;; Check 1: Action must be a valid plist
(unless (listp action)
(return-from policy-check-transparency
(list :type :LOG
:payload (list :level :error
:text "POLICY [Transparency]: Action is not a valid plist. Rejected."))))
(let* ((payload (getf action :payload))
(target (or (getf action :target) (getf action :TARGET)))
(explanation (or (getf payload :explanation) (getf payload :EXPLANATION)
(getf payload :rationale) (getf payload :RATIONALE))))
;; User-facing actions (CLI, TUI, Emacs) must explain themselves
(explanation (or (getf payload :explanation)
(getf payload :EXPLANATION)
(getf payload :rationale)
(getf payload :RATIONALE))))
;; Check 2: User-facing actions require explanation
(when (and (member target '(:cli :tui :emacs :EMACS :CLI :TUI))
(not explanation)
(not (member (getf payload :action)
@@ -31,172 +49,320 @@ Returns the action if clean, or a blocking LOG event if the action is opaque."
(return-from policy-check-transparency
(list :type :LOG
:payload (list :level :error
:text "POLICY [Transparency]: User-facing action missing :explanation. Blocked."))))
action))
:text "POLICY [Transparency]: User-facing action missing :explanation. Blocked.")))))
action))
(defvar *proprietary-domain-watchlist*
'("googleapis.com" "api.openai.com" "anthropic.com" "api.groq.com" "openrouter.ai")
"Domains that represent centralized, proprietary control.
Actions targeting these are logged as autonomy debt, not hard-blocked,
because tactical gateway usage is permitted under the strategic mandate.")
"Domains representing centralized, proprietary control.
Actions targeting these are logged as autonomy debt, not hard-blocked.
This is because tactical gateway usage (Telegram, Signal, OpenRouter)
is permitted under the strategic mandate for autonomy.
Strategic goal: Replace all proprietary APIs with local alternatives.
Tactical reality: Use what's available while building toward that goal.")
(defun policy-scan-proprietary-references (action)
"Scans ACTION text fields for proprietary domain references.
Returns the first matched domain, or NIL if clean."
Searches in:
- :text and :TEXT in payload
- :cmd and :CMD in payload
- :cmd in args (for shell tool calls)
Returns the first matched domain, or NIL if clean."
(let* ((payload (getf action :payload))
(text (or (getf payload :text) (getf payload :TEXT) ""))
(cmd (or (getf payload :cmd) (getf payload :CMD)
(when (equal (getf payload :tool) "shell")
(getf (getf payload :args) :cmd))
""))
(cmd (or (getf payload :cmd)
(getf payload :CMD)
(when (equal (getf payload :tool) "shell")
(getf (getf payload :args) :cmd))
""))
(haystack (concatenate 'string text cmd)))
(dolist (domain *proprietary-domain-watchlist* nil)
(when (search domain haystack)
(return domain)))))
(defun policy-check-autonomy (action context)
"Flags actions that reference proprietary domains. Returns the action
with an autonomy debt log appended, or the action itself if clean."
"Flags actions that reference proprietary domains.
Does NOT block the action—this is a warning, not a veto.
The agent can use proprietary services tactically, but must
be aware that each usage is a step away from full autonomy.
Returns a warning LOG if proprietary reference detected,
or the original action if clean."
(declare (ignore context))
(let ((domain (policy-scan-proprietary-references action)))
(if domain
(progn
(harness-log "POLICY [Autonomy]: Detected proprietary reference '~a'. Flagged for replacement." domain)
;; Return a side-effect log but DO NOT block the action
;; Return a warning log but DO NOT block the action
(list :type :LOG
:payload (list :level :warn
:text (format nil "Autonomy Debt: Action references proprietary domain '~a'. Consider a local alternative." domain)
:original-action action)))
action)))
(defvar *policy-max-skill-size-chars* 50000
"Maximum recommended size for a skill file tangled from an Org note.")
"Maximum recommended size for a skill file tangled from an Org note.
This is a soft limit—the check warns but does not block.
A large, well-documented skill is acceptable; a small, poorly-documented
one that adds unnecessary complexity is not.")
(defun policy-check-bloat (action context)
"Warns if a :create-skill action exceeds the bloat threshold.
Does not block, because size alone is not a proof of complexity."
Size alone is not proof of complexity—a 50KB skill that's well-designed
is better than a 5KB skill that's spaghetti. This check flags for review,
not automatic rejection.
Returns a warning LOG if threshold exceeded, or original action if clean."
(declare (ignore context))
(let* ((payload (getf action :payload))
(act (getf payload :action))
(content (getf payload :content)))
(when (and (eq act :create-skill)
(stringp content)
(> (length content) *policy-max-skill-size-chars*))
(harness-log "POLICY [Bloat]: Proposed skill is ~a chars. Exceeds ~a char threshold."
(length content) *policy-max-skill-size-chars*)
(return-from policy-check-bloat
(list :type :LOG
:payload (list :level :warn
:text (format nil "Bloat Warning: Proposed skill (~a chars) exceeds ~a char threshold. Review for earned complexity."
(length content) *policy-max-skill-size-chars*)
(length content) *policy-max-skill-size-chars*)
:original-action action))))
action))
(defvar *mentorship-required-actions*
'(:create-skill :eval :modify-file :write-file :replace :rename-file :delete-file :shell :create-note)
"Actions that trigger the Mentorship invariant.")
(defun policy-check-mentorship (action context)
"Blocks high-impact actions that lack a mentorship note."
(declare (ignore context))
(let* ((payload (getf action :payload))
(act (or (getf payload :action) (getf action :action)))
(note (or (getf payload :mentorship-note) (getf payload :MENTORSHIP-NOTE)))
(target (or (getf action :target) (getf action :TARGET)))
(tool (when (eq target :tool) (getf payload :tool))))
(when (or (member act *mentorship-required-actions*)
(member tool '("shell" "eval" "repair-file")))
(unless note
(return-from policy-check-mentorship
(list :type :LOG
:payload (list :level :error
:text "POLICY [Mentorship]: High-impact action missing :mentorship-note. Explain what you are doing and why. Blocked.")))))
action))
(defvar *cloud-only-backends* '(:openrouter :openai :anthropic :groq :gemini-api)
"Backends that require an internet connection and external infrastructure.")
(defun policy-check-sustainability (action context)
"Logs sustainability debt when the action relies on cloud-only infrastructure.
Does not block, because tactical cloud usage is permitted."
(let* ((payload (getf context :payload))
(backend (getf payload :backend))
(provider (getf payload :provider)))
(when (or (member backend *cloud-only-backends*)
(member provider *cloud-only-backends*))
(harness-log "POLICY [Sustainability]: Cloud provider '~a' used. Logged as sustainability debt."
(or backend provider))
(return-from policy-check-sustainability
(list :type :LOG
:payload (list :level :warn
:text (format nil "Sustainability Debt: Reliance on cloud provider '~a'. Consider Ollama or local inference."
(or backend provider))))))
action))
action))
(defvar *modularity-protected-paths*
'("harness/" "opencortex.asd")
"Paths that constitute the unbreakable core of the system.
Any action targeting these paths must include a :modularity-justification.
This list is project-specific and should be configured at boot time.")
Any action targeting these paths must include a :modularity-justification
explaining why the change cannot be implemented as a skill.
The Thin Harness principle: What belongs in the harness?
- Core signal processing (Perceive-Reason-Act loop)
- Memory and persistence primitives
- Protocol definition and validation
- Skills register and dispatch
What belongs in skills?
- Policy and security
- LLM integration
- Domain-specific functionality
- New actuators")
(defun policy-check-modularity (action context)
"Blocks modifications to the system's protected core unless justified."
"Blocks modifications to the system's protected core unless justified.
MODULARITY CHECK:
1. If the action targets a protected path
2. And no :modularity-justification is provided
3. Then block with an explanation
The justification should explain WHY the change cannot be a skill.
Common valid reasons:
- The change fixes a bug in the harness itself
- The change adds a primitive that skills cannot implement
- The change is required for security hardening
Invalid reasons:
- 'It's easier to modify the harness'
- 'Skills are too slow'
- 'I want to keep it all in one place'"
(declare (ignore context))
(let* ((payload (getf action :payload))
(target-file (or (getf payload :file) (getf payload :filename)))
(target-file (or (getf payload :file)
(getf payload :filename)))
(justification (or (getf payload :modularity-justification)
(getf payload :MODULARITY-JUSTIFICATION))))
(when (and target-file
(some (lambda (path) (search path target-file)) *modularity-protected-paths*)
(some (lambda (path) (search path target-file))
*modularity-protected-paths*)
(not justification))
(return-from policy-check-modularity
(list :type :LOG
:payload (list :level :error
:text "POLICY [Modularity]: Modification to protected core path blocked. Provide :modularity-justification explaining why this cannot be a skill."
:blocked-path target-file))))
action))
action))
(defvar *mentorship-required-actions*
'(:create-skill :eval :modify-file :write-file :replace
:rename-file :delete-file :shell :create-note)
"Actions that trigger the Mentorship invariant.
These are high-impact actions that should come with explanations
not just for the user, but for future debugging and maintenance.")
(defun policy-check-mentorship (action context)
"Blocks high-impact actions that lack a mentorship note.
MENTORSHIP CHECK:
1. If the action is in *mentorship-required-actions*
2. Or if the action calls shell/eval/repair-file tools
3. Then require :mentorship-note explaining what and why
The mentorship note should be:
- Concise (1-2 sentences)
- Educational (explain the principle, not just the action)
- Actionable (help the user understand the outcome)"
(declare (ignore context))
(let* ((payload (getf action :payload))
(act (or (getf payload :action)
(getf action :action)))
(note (or (getf payload :mentorship-note)
(getf payload :MENTORSHIP-NOTE)))
(target (or (getf action :target)
(getf action :TARGET)))
(tool (when (eq target :tool)
(getf payload :tool))))
(when (or (member act *mentorship-required-actions*)
(member tool '("shell" "eval" "repair-file")))
(unless note
(return-from policy-check-mentorship
(list :type :LOG
:payload (list :level :error
:text "POLICY [Mentorship]: High-impact action missing :mentorship-note. Explain what you are doing and why. Blocked.")))))
action))
(defvar *cloud-only-backends* '(:openrouter :openai :anthropic :groq :gemini-api)
"Backends requiring internet connection and external infrastructure.
These are acceptable as fallbacks when local inference is unavailable,
but should be logged as sustainability debt for tracking purposes.")
(defun policy-check-sustainability (action context)
"Logs sustainability debt when action relies on cloud-only infrastructure.
Does NOT block—this is informational, not prohibitive.
Cloud usage is acceptable tactically (when local models fail),
but every cloud usage should be a conscious decision, not a default."
(let* ((payload (getf context :payload))
(backend (getf payload :backend))
(provider (getf payload :provider)))
(when (or (member backend *cloud-only-backends*)
(member provider *cloud-only-backends*))
(harness-log "POLICY [Sustainability]: Cloud provider '~a' used. Logged as sustainability debt."
(or backend provider))
(return-from policy-check-sustainability
(list :type :LOG
:payload (list :level :warn
:text (format nil "Sustainability Debt: Reliance on cloud provider '~a'. Consider Ollama or local inference."
(or backend provider))))))
action)))
(defun policy-explain (invariant-key message &optional original-action)
"Formats a policy decision into an auditable explanation plist.
INVARIANT-KEY is one of :transparency, :autonomy, :bloat, :modularity, :mentorship, :sustainability.
MESSAGE is a human-readable string.
ORIGINAL-ACTION is the action that was blocked or modified."
INVARIANT-KEY is one of:
:transparency, :autonomy, :bloat, :modularity, :mentorship, :sustainability
MESSAGE is a human-readable string explaining the decision.
ORIGINAL-ACTION is the action that was blocked or modified.
Returns a REQUEST plist addressed to the original source,
containing the explanation and original action for transparency."
(list :type :REQUEST
:target (or (ignore-errors (getf (getf original-action :meta) :source)) :cli)
:target (or (ignore-errors
(getf (getf original-action :meta) :source))
:cli)
:payload (list :action :message
:text (format nil "[POLICY ~a] ~a" invariant-key message)
:explanation (format nil "Invariant: ~a | Rationale: ~a" invariant-key message)
:explanation (format nil "Invariant: ~a | Rationale: ~a"
invariant-key message)
:original-action original-action)))
(defun policy-run-invariant-checks (action context)
"Runs all invariant checks in priority order. Returns the final action,
a blocking LOG event, or a warning wrapper."
"Runs all invariant checks in priority order.
Priority order (from *policy-invariant-priorities*):
1. Transparency (500) - blocks non-transparent actions
2. Autonomy (400) - warns on proprietary dependencies
3. Bloat (300) - warns on oversized skills
4. Modularity (250) - blocks unprotected core modifications
5. Mentorship (200) - blocks unexplained high-impact actions
6. Sustainability (100) - warns on cloud dependencies
Returns:
- The final action (possibly modified by checks)
- A blocking LOG event (if any check returned :error level)
- A warning wrapper (if checks returned :warn level but no blocks)"
(let ((checks '(policy-check-transparency
policy-check-autonomy
policy-check-bloat
policy-check-modularity
policy-check-mentorship
policy-check-sustainability)))
(dolist (check-fn checks action)
(let ((result (funcall check-fn action context)))
;; If the check returned a LOG event, treat it as a block/warning
;; If the check returned a LOG/EVENT, interpret it
(when (and (listp result)
(member (getf result :type) '(:LOG :EVENT)))
(let ((level (getf (getf result :payload) :level)))
(cond ((eq level :error)
;; Hard block: return the log event directly
(return-from policy-run-invariant-checks result))
(t
;; Warning: log it, but continue with the original action
(harness-log "~a" (getf (getf result :payload) :text))))))))))
(let ((level (getf (getf result :payload) :level)))
(cond
;; Hard block: error level stops processing immediately
((eq level :error)
(return-from policy-run-invariant-checks result))
;; Soft warning: log but continue with original action
(t
(harness-log "~a" (getf (getf result :payload) :text)))))))))
action))
(defun policy-find-engineering-standards-gate ()
"Searches for the Engineering Standards gate across known jailed package names.
Returns the function symbol, or NIL if unavailable."
The standards skill may be in opencortex-contrib submodule,
so we search multiple possible package names with graceful fallback.
Returns the function symbol, or NIL if unavailable."
(dolist (pkg-name '(:opencortex.skills.org-skill-engineering-standards
:opencortex.skills.org-skill-engineering
:opencortex.skills.engineering-standards)
nil)
(let ((pkg (find-package pkg-name)))
(when pkg
(let ((sym (find-symbol "ENGINEERING-STANDARDS-GATE" pkg)))
@@ -204,18 +370,31 @@ Returns the function symbol, or NIL if unavailable."
(return (symbol-function sym))))))))
(defun policy-deterministic-gate (action context)
"The main policy gate. Runs invariant checks, then delegates to engineering standards if available.
Never returns NIL silently; always returns an action or an auditable log event."
"The main policy gate entry point.
This function is registered as the deterministic-fn for the policy skill.
It runs invariant checks, then delegates to engineering standards if loaded.
IMPORTANT: Never returns NIL silently. Always returns either:
- An action (possibly modified)
- A blocking LOG event with explanation
- A warning wrapper with explanation"
;; Step 1: Run invariant checks
(let ((current-action (policy-run-invariant-checks action context)))
;; If an invariant returned a blocking log, do not proceed further
;; Step 2: If an invariant blocked the action, stop here
(when (and (listp current-action)
(member (getf current-action :type) '(:LOG :EVENT))
(eq (getf (getf current-action :payload) :level) :error))
(return-from policy-deterministic-gate current-action))
;; Delegate to Engineering Standards if loaded
;; Step 3: Delegate to Engineering Standards if loaded
(let ((eng-gate (policy-find-engineering-standards-gate)))
(when eng-gate
(setf current-action (funcall eng-gate current-action context))))
current-action))
(defskill :skill-policy

View File

@@ -116,3 +116,62 @@ Provide a fixed version of the code as a lisp form.")
(list :status :success :repaired balanced))
(error (c)
(list :status :error :message (format nil "Could not repair: ~a" c)))))))
(defvar *self-edit-skills-backup* nil
"Backup of skill registry before hot-reload.")
(defun self-edit-hot-reload-skill (skill-name gen-path)
"Reloads a skill from its compiled .lisp source.
Steps:
1. Backup current *skills-registry*
2. Compile the new skill file
3. Merge new skill into registry
4. Verify the skill loads without error
5. If error, rollback to backup
Returns (values :success t) or (values :error message)."
(unless *skills-registry*
(return-from self-edit-hot-reload-skill
(values :error "Skills engine not initialized")))
(unless (uiop:file-exists-p gen-path)
(return-from self-edit-hot-reload-skill
(values :error (format nil "Skill file not found: ~a" gen-path))))
;; Step 1: Backup registry
(setf *self-edit-skills-backup* (copy-hash-table *skills-registry*))
(handler-case
(progn
;; Step 2: Compile new skill
(let ((compiled (compile-file gen-path)))
(unless compiled
(error "Compilation returned nil")))
;; Step 3: Load the compiled skill
(load gen-path)
;; Step 4: Verify skill is in registry
(let ((skill (gethash (string skill-name) *skills-registry*)))
(if skill
(progn
(harness-log "SELF-EDIT: Hot-reloaded skill ~a from ~a"
skill-name gen-path)
(values :success t))
(error "Skill not registered after reload"))))
(error (e)
;; Step 5: Rollback
(when *self-edit-skills-backup*
(clrhash *skills-registry*)
(maphash (lambda (k v) (setf (gethash k *skills-registry*) v))
*self-edit-skills-backup*))
(harness-log "SELF-EDIT: Hot-reload FAILED for ~a: ~a" skill-name e)
(values :error (format nil "Hot-reload failed: ~a" e)))))
(def-cognitive-tool :reload-skill
"Hot-reloads a skill from its compiled source file without restarting the system."
((:skill-name :type :string :description "Name of the skill to reload (e.g. :skill-engineering-standards)")
(:gen-path :type :string :description "Absolute path to the compiled .lisp file"))
:body (lambda (args)
(let ((name (getf args :skill-name))
(path (getf args :gen-path)))
(multiple-value-bind (status message) (self-edit-hot-reload-skill name path)
(list :status status :message message)))))

View File

@@ -1,99 +1,193 @@
(in-package :opencortex)
(defvar *interrupt-flag* nil)
(defvar *interrupt-lock* (bordeaux-threads:make-lock "harness-interrupt-lock"))
(defvar *heartbeat-thread* nil)
(defvar *interrupt-flag* nil
"Atomic flag set by signal handlers to trigger graceful shutdown.
Using a dedicated variable avoids race conditions in interrupt handling.")
(defvar *interrupt-lock* (bt:make-lock "harness-interrupt-lock")
"Mutex protecting *interrupt-flag* access.
Locking is required because SBCL's interrupt handlers run in uncertain contexts.")
(defvar *heartbeat-thread* nil
"Handle to the heartbeat thread, allowing explicit termination on shutdown.")
(defun process-signal (signal)
"The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act."
"The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act.
SIGNAL is a property list with the following structure:
- :type - :EVENT, :REQUEST, :RESPONSE, etc.
- :payload - The actual content (sensor data, approved actions, etc.)
- :meta - Metadata including source, session, reply stream
- :depth - Recursion depth counter (starts at 0)
- :status - Processing status (:perceived, :reasoned, :acted)
Returns NIL when processing is complete, or a new signal for feedback loop."
(let ((current-signal signal))
(loop while current-signal do
;; Depth limiting prevents infinite recursion from feedback loops
(let ((depth (getf current-signal :depth 0))
(meta (getf current-signal :meta)))
(when (> depth 10) (harness-log "METABOLISM ERROR: Max depth reached.") (return nil))
(when (bordeaux-threads:with-lock-held (*interrupt-lock*) *interrupt-flag*)
(harness-log "METABOLISM: Interrupted.")
(bordeaux-threads:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* nil))
(when (> depth 10)
(harness-log "METABOLISM ERROR: Max recursion depth reached.")
(return nil))
;; Check for graceful shutdown interrupt
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
(harness-log "METABOLISM: Interrupted by shutdown signal.")
(bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* nil))
(return nil))
;; The three-stage pipeline wrapped in error handling
(handler-case
(progn
;; Stage 1: Perceive - normalize sensory input
(setf current-signal (perceive-gate current-signal))
;; Stage 2: Reason - generate and verify action proposals
(setf current-signal (reason-gate current-signal))
;; Stage 3: Act - execute approved actions
(let ((feedback (act-gate current-signal)))
;; feedback generation
(if feedback
;; Action generated a feedback signal - continue processing
(progn
;; Inherit meta from trigger signal
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
;; Preserve metadata from original signal
(unless (getf feedback :meta)
(setf (getf feedback :meta) meta))
(setf current-signal feedback))
;; No feedback - pipeline complete
(setf current-signal nil))))
;; Error recovery with differentiated response
(error (c)
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
(harness-log "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
;; Only rollback on critical errors, not standard tool or loop errors
;; Only rollback memory on critical errors, not transient tool failures
;; This prevents losing recent context due to a single bad API call
(unless (member sensor '(:loop-error :tool-error :syntax-error))
(harness-log "CRITICAL ERROR: Initiating Micro-Rollback.")
(rollback-memory 0))
;; At deep recursion or known error types, terminate gracefully
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
(setf current-signal nil)
(setf current-signal (list :type :EVENT :depth (1+ depth) :meta meta
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))))))
;; Otherwise, convert error to a loop-error signal for retry
(setf current-signal
(list :type :EVENT
:depth (1+ depth)
:meta meta
:payload (list :sensor :loop-error
:message (format nil "~a" c)
:depth depth)))))))))))
(defvar *auto-save-interval* 300
"Save memory to disk every N seconds. Set from MEMORY_AUTO_SAVE_INTERVAL env.")
"Interval in seconds between automatic memory saves.
Defaults to 300 seconds (5 minutes). Set via MEMORY_AUTO_SAVE_INTERVAL env var.")
(defvar *heartbeat-save-counter* 0
"Counter for auto-save triggers.")
"Tracks heartbeats since last save, used to calculate auto-save timing.")
(defun start-heartbeat ()
"Starts the background heartbeat thread. Interval is loaded from HEARTBEAT_INTERVAL."
"Starts the background heartbeat thread.
The heartbeat runs in a dedicated thread to avoid blocking the main
signal processing loop. Each heartbeat:
1. Injects a :HEARTBEAT signal into the metabolic pipeline
2. Checks if memory should be auto-saved (based on interval ratio)
Configuration via environment:
- HEARTBEAT_INTERVAL: Seconds between heartbeats (default: 60)
- MEMORY_AUTO_SAVE_INTERVAL: Seconds between auto-saves (default: 300)"
(let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60))
(auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) *auto-save-interval*)))
(setf *auto-save-interval* auto-save)
(setf *heartbeat-save-counter* 0)
(setf *heartbeat-thread*
(bordeaux-threads:make-thread
(lambda ()
(loop
(sleep interval)
(setf *heartbeat-thread*
(bt:make-thread
(lambda ()
(loop
;; Wait for interval
(sleep interval)
;; Update counter and check if it's time to save
(incf *heartbeat-save-counter*)
(when (>= *heartbeat-save-counter* (/ *auto-save-interval* interval))
(setf *heartbeat-save-counter* 0)
(save-memory-to-disk))
;; inject-stimulus is synchronous for heartbeats, preventing accumulation.
(inject-stimulus (list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
:name "opencortex-heartbeat"))))
;; Inject heartbeat signal - this runs through the full pipeline
;; allowing the agent to do latent reflection even with no input
(inject-stimulus
(list :type :EVENT
:payload (list :sensor :heartbeat
:unix-time (get-universal-time)))))
:name "opencortex-heartbeat")))))
(defvar *shutdown-save-enabled* t
"If non-nil, save memory to disk on graceful shutdown.")
"When T, save memory to disk on graceful shutdown.
Disable for testing or when memory persistence is handled externally.")
(defun main ()
"Entry point for the Skeleton MVP. Handles initialization and graceful shutdown."
(let* ((home (uiop:getenv "HOME"))
(env-file (uiop:merge-pathnames* ".local/share/opencortex/.env" (uiop:ensure-directory-pathname home))))
(when (uiop:file-exists-p env-file) (cl-dotenv:load-env env-file)))
"Entry point for OpenCortex. Initializes the system and enters idle loop.
;; Load memory from disk if a snapshot exists
Startup sequence:
1. Load environment from ~/.local/share/opencortex/.env
2. Restore memory from disk (if snapshot exists)
3. Initialize actuators (shell, cli, system)
4. Load all skills from SKILLS_DIR
5. Start heartbeat thread
6. Register SIGINT handler for graceful shutdown
7. Enter idle loop (sleeps in DAEMON_SLEEP_INTERVAL chunks)
The idle loop checks for interrupts and saves memory before exit."
;; Step 1: Load environment variables from standard location
(let* ((home (uiop:getenv "HOME"))
(env-file (uiop:merge-pathnames*
".local/share/opencortex/.env"
(uiop:ensure-directory-pathname home))))
(when (uiop:file-exists-p env-file)
(cl-dotenv:load-env env-file)))
;; Step 2: Crash recovery - load memory from previous snapshot
(load-memory-from-disk)
;; Step 3-4: Initialize actuators and load skills
(initialize-actuators)
(initialize-all-skills)
;; Step 5: Start the heartbeat
(start-heartbeat)
;; Graceful shutdown handler for SBCL
;; Step 6: Register graceful shutdown handler
;; SBCL-specific: catches Ctrl+C (SIGINT) and saves before exit
#+sbcl
(sb-sys:enable-interrupt sb-unix:sigint
(lambda (sig code scp)
(declare (ignore sig code scp))
(sb-sys:enable-interrupt sb-unix:sigint
(lambda (sig code scp)
(declare (ignore sig code scp))
(harness-log "SHUTDOWN: SIGINT received. Saving memory...")
(when *shutdown-save-enabled* (save-memory-to-disk))
(when *shutdown-save-enabled*
(save-memory-to-disk))
(uiop:quit 0)))
(let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600)))
(loop
(when (bordeaux-threads:with-lock-held (*interrupt-lock*) *interrupt-flag*)
;; Step 7: Idle loop - sleep in chunks, checking for interrupts
(let ((sleep-interval (or (ignore-errors
(parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL")))
3600)))
(loop
;; Check for interrupt before each sleep cycle
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
(harness-log "SHUTDOWN: Interrupt flag set. Saving memory...")
(when *shutdown-save-enabled* (save-memory-to-disk))
(when *shutdown-save-enabled*
(save-memory-to-disk))
(return))
;; Sleep in configured intervals (default: 1 hour)
(sleep sleep-interval))))

View File

@@ -8,6 +8,10 @@
(defstruct org-object
id type attributes content vector parent-id children version last-sync hash)
;; Enable serialization via make-load-form (standard CL)
(defmethod make-load-form ((obj org-object) &optional env)
(make-load-form-saving-slots obj :environment env))
(defun compute-merkle-hash (id type attributes content child-hashes)
"Computes a SHA-256 Merkle hash for a node based on its core properties and children's hashes."
(let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v)))
@@ -79,53 +83,61 @@
(harness-log "MEMORY - Memory rolled back to snapshot ~a" index))
(harness-log "MEMORY ERROR - Snapshot ~a not found." index))))
(defvar *memory-snapshot-path* nil
"Path to the memory snapshot file. Set from MEMORY_SNAPSHOT_PATH env or default.")
(defvar *embedding-cache* (make-hash-table :test 'equal)
"Cache for embeddings to avoid redundant API calls.")
(defun ensure-memory-snapshot-path ()
"Initializes the snapshot path from environment or default location."
(or *memory-snapshot-path*
(let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH")))
(setf *memory-snapshot-path*
(or env-path
(uiop:merge-pathnames* "memory.snap" (user-homedir-pathname)))))))
(defun get-embedding (text)
"Generates a vector embedding for the given text via Ollama. Returns nil on failure."
(when (or (null text) (string= text ""))
(return-from get-embedding nil))
(let ((cached (gethash text *embedding-cache*)))
(when cached (return-from get-embedding cached)))
(let ((result (funcall (get-cognitive-tool-body :get-ollama-embedding) (list :text text))))
(when (eq (getf result :status) :success)
(let ((vec (getf result :vector)))
(setf (gethash text *embedding-cache*) vec)
vec))))
(defun save-memory-to-disk ()
"Serializes *memory* and *history-store* to disk for crash recovery.
Converts hash tables to alists for proper serialization."
(let ((path (ensure-memory-snapshot-path)))
(with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create)
(format stream ";; OpenCortex Memory Snapshot~%")
(format stream ";; Created: ~a~%~%" (format nil "~a" (get-universal-time)))
(let ((memory-alist nil)
(history-alist nil))
(maphash (lambda (k v) (push (cons k v) memory-alist)) *memory*)
(maphash (lambda (k v) (push (cons k v) history-alist)) *history-store*)
(prin1 (list :memory memory-alist :history-store history-alist) stream)))
(harness-log "MEMORY - Saved to ~a" path)
path))
(defun cosine-similarity (vec-a vec-b)
"Computes cosine similarity between two vectors. Both should be sequences of numbers."
(when (or (null vec-a) (null vec-b) (zerop (length vec-a)) (zerop (length vec-b)))
(return-from cosine-similarity 0.0))
(let ((dot-product (loop for a across vec-a
for b across vec-b
sum (* a b)))
(norm-a (sqrt (loop for a across vec-a sum (* a a))))
(norm-b (sqrt (loop for b across vec-b sum (* b b)))))
(if (or (zerop norm-a) (zerop norm-b))
0.0
(/ dot-product (* norm-a norm-b)))))
(defun load-memory-from-disk ()
"Loads *memory* and *history-store* from disk if the snapshot exists.
Reconstitutes alists into hash tables."
(let ((path (ensure-memory-snapshot-path)))
(when (uiop:file-exists-p path)
(handler-case
(with-open-file (stream path :direction :input)
(let ((data (read stream nil)))
(when data
(let ((memory-alist (getf data :memory))
(history-alist (getf data :history-store)))
(setf *memory* (make-hash-table :test 'equal :size (length memory-alist)))
(dolist (kv memory-alist)
(setf (gethash (car kv) *memory*) (cdr kv)))
(setf *history-store* (make-hash-table :test 'equal :size (length history-alist)))
(dolist (kv history-alist)
(setf (gethash (car kv) *history-store*) (cdr kv)))
(harness-log "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory*))))))
(error (c)
(harness-log "MEMORY WARNING - Failed to load snapshot: ~a" c))))
t))
(defun semantic-search (query &key (limit 10) (min-similarity 0.5))
"Searches memory for objects semantically similar to the query.
Returns up to LIMIT objects with similarity >= MIN-SIMILARITY, sorted by similarity descending."
(let* ((query-vec (get-embedding query))
(results nil))
(unless query-vec
(harness-log "EMBEDDING: Failed to generate embedding for query: ~a" query)
(return-from semantic-search nil))
(maphash (lambda (id obj)
(let ((obj-vec (org-object-vector obj)))
(when obj-vec
(let ((sim (cosine-similarity query-vec obj-vec)))
(when (>= sim min-similarity)
(push (list :id id :object obj :similarity sim) results))))))
*memory*)
(setf results (sort results #'> :key (lambda (r) (getf r :similarity))))
(subseq results 0 (min limit (length results)))))
(def-cognitive-tool :semantic-search
"Searches memory for objects semantically similar to a query."
((:query :type :string :description "The search query.")
(:limit :type :integer :description "Maximum results to return." :default 10)
(:min-similarity :type :number :description "Minimum similarity threshold (0-1)." :default 0.5))
:body (lambda (args)
(semantic-search (getf args :query)
:limit (or (getf args :limit) 10)
:min-similarity (or (getf args :min-similarity) 0.5))))
(defun org-id-new ()
"Generates a new UUID string for Org-mode identification."
@@ -161,58 +173,3 @@ Reconstitutes alists into hash tables."
(defun file-name-nondirectory (path)
"Extracts the filename from a full path string."
(let ((pos (position #\/ path :from-end t))) (if pos (subseq path (1+ pos)) path)))
(defvar *embedding-cache* (make-hash-table :test 'equal)
"Cache for embeddings to avoid redundant API calls.")
(defun get-embedding (text)
"Generates a vector embedding for the given text via Ollama. Returns nil on failure."
(when (or (null text) (string= text ""))
(return-from get-embedding nil))
(let ((cached (gethash text *embedding-cache*)))
(when cached (return-from get-embedding cached)))
(let ((result (funcall (get-cognitive-tool-body :get-ollama-embedding) (list :text text))))
(when (eq (getf result :status) :success)
(let ((vec (getf result :vector)))
(setf (gethash text *embedding-cache*) vec)
vec))))
(defun cosine-similarity (vec-a vec-b)
"Computes cosine similarity between two vectors. Both should be sequences of numbers."
(when (or (null vec-a) (null vec-b) (zerop (length vec-a)) (zerop (length vec-b)))
(return-from cosine-similarity 0.0))
(let ((dot-product (loop for a across vec-a
for b across vec-b
sum (* a b)))
(norm-a (sqrt (loop for a across vec-a sum (* a a))))
(norm-b (sqrt (loop for b across vec-b sum (* b b)))))
(if (or (zerop norm-a) (zerop norm-b))
0.0
(/ dot-product (* norm-a norm-b)))))
(defun semantic-search (query &key (limit 10) (min-similarity 0.5))
"Searches memory for objects semantically similar to the query."
(let* ((query-vec (get-embedding query))
(results nil))
(unless query-vec
(harness-log "EMBEDDING: Failed to generate embedding for query: ~a" query)
(return-from semantic-search nil))
(maphash (lambda (id obj)
(let ((obj-vec (org-object-vector obj)))
(when obj-vec
(let ((sim (cosine-similarity query-vec obj-vec)))
(when (>= sim min-similarity)
(push (list :id id :object obj :similarity sim) results))))))
*memory*)
(setf results (sort results #'> :key (lambda (r) (getf r :similarity))))
(subseq results 0 (min limit (length results)))))
(def-cognitive-tool :semantic-search
"Searches memory for objects semantically similar to a query."
((:query :type :string :description "The search query.")
(:limit :type :integer :description "Maximum results to return." :default 10)
(:min-similarity :type :number :description "Minimum similarity threshold (0-1)." :default 0.5))
:body (lambda (args)
(semantic-search (getf args :query)
:limit (or (getf args :limit) 10)
:min-similarity (or (getf args :min-similarity) 0.5))))

View File

@@ -1,60 +1,130 @@
(in-package :opencortex)
(defvar *async-sensors* '(:chat-message :delegation :user-command)
"List of sensors that should be processed asynchronously to avoid blocking gateways.")
"Sensors that are processed in dedicated threads.
These sensors can block (waiting for API responses, user input, etc.)
so they run in separate threads to avoid blocking the main pipeline.
Other sensors (:heartbeat, :interrupt, :buffer-update) are processed
synchronously to maintain temporal ordering.")
(defvar *foveal-focus-id* nil
"The Org ID of the node the user is currently interacting with.")
"The Org ID of the node the user is currently interacting with.
This enables the reasoning engine to provide contextually relevant
responses. When editing a specific note, the agent knows which
note you're referring to without needing explicit ID references.
Updated on :point-update events from Emacs.")
(defun inject-stimulus (raw-message &key stream (depth 0))
"Enqueues a raw message into the reactive signal pipeline."
(let* ((payload (getf raw-message :payload))
"Inject a raw message into the signal processing pipeline.
RAW-MESSAGE is a property list that will be normalized into a Signal.
STREAM is an optional output stream for responses (used by TUI/CLI).
DEPTH tracks recursion depth for feedback loops.
This function determines whether to process synchronously or
asynchronously based on the sensor type, then calls process-signal
to run through the Perceive -> Reason -> Act pipeline.
Error handling: Uses restarts to prevent individual signals from
crashing the entire system. Failed signals are logged and dropped."
(let* ((payload (getf raw-message :payload))
(sensor (getf payload :sensor))
(meta (getf raw-message :meta))
(async-p (or (getf payload :async-p) (member sensor *async-sensors*))))
;; Ensure META exists and contains the stream if provided
(unless meta (setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal")))
(when stream (setf (getf meta :reply-stream) stream))
(async-p (or (getf payload :async-p)
(member sensor *async-sensors*))))
;; Ensure metadata exists
(unless meta
(setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal")))
;; Attach reply stream if provided
(when stream
(setf (getf meta :reply-stream) stream))
(setf (getf raw-message :meta) meta)
(if async-p
(bordeaux-threads:make-thread
(lambda ()
(restart-case (handler-bind ((error (lambda (c) (harness-log "ASYNC ERROR: ~a" c) (invoke-restart 'skip-event))))
(process-signal raw-message))
(skip-event () nil)))
(if async-p
;; Async: process in dedicated thread
(bt:make-thread
(lambda ()
(restart-case
(handler-bind ((error (lambda (c)
(harness-log "ASYNC ERROR: ~a" c)
(invoke-restart 'skip-event))))
(process-signal raw-message))
(skip-event () nil)))
:name "opencortex-async-task")
(restart-case (handler-bind ((error (lambda (c) (harness-log "SYSTEM ERROR: ~a" c) (invoke-restart 'skip-event))))
(process-signal raw-message))
(skip-event () (harness-log "SYSTEM RECOVERY: Stimulus dropped.~%"))))))
;; Sync: process in main thread with recovery
(restart-case
(handler-bind ((error (lambda (c)
(harness-log "SYSTEM ERROR: ~a" c)
(invoke-restart 'skip-event))))
(process-signal raw-message))
(skip-event ()
(harness-log "SYSTEM RECOVERY: Stimulus dropped."))))))
(defun perceive-gate (signal)
"Initial processing: Normalizes raw stimuli and updates memory."
"Stage 1 of the metabolic pipeline: Normalize sensory input.
This function:
1. Logs the incoming signal for debugging
2. Handles special sensor types (:buffer-update, :point-update, etc.)
3. Updates the Memory graph with incoming data
4. Tracks foveal focus (user's current node)
5. Sets :status to :perceived
Modifies the signal in place and returns it for the next stage.
Memory snapshots are taken before AST updates to enable rollback
if the update causes issues."
(let* ((payload (getf signal :payload))
(type (getf signal :type))
(meta (getf signal :meta))
(sensor (getf payload :sensor)))
(harness-log "GATE [Perceive]: ~a (~a) [Source: ~s]" type (or sensor "no-sensor") (getf meta :source))
;; Log the incoming signal for debugging
(harness-log "GATE [Perceive]: ~a (~a) [Source: ~s]"
type (or sensor "no-sensor") (getf meta :source))
;; Handle EVENT type sensors
(cond ((eq type :EVENT)
(case sensor
(:buffer-update
(let ((ast (getf payload :ast)))
(when ast
(snapshot-memory)
;; Org buffer was modified - update memory
(:buffer-update
(let ((ast (getf payload :ast)))
(when ast
(snapshot-memory) ; Enable rollback if update causes issues
(ingest-ast ast))))
(:point-update
(let ((element (getf payload :element)))
(when element
;; Point moved to different org node - update focus
(:point-update
(let ((element (getf payload :element)))
(when element
(snapshot-memory)
(setf *foveal-focus-id* (ignore-errors (getf element :id)))
;; Track foveal focus for contextual reasoning
(setf *foveal-focus-id*
(ignore-errors (getf element :id)))
(ingest-ast element))))
(:interrupt
(bordeaux-threads:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* t)))))
;; System interrupt - trigger shutdown
(:interrupt
(bt:with-lock-held (*interrupt-lock*)
(setf *interrupt-flag* t)))))
;; Log responses from actuators
((eq type :RESPONSE)
(harness-log "GATE [Perceive]: Act Result -> ~a" (getf payload :status))))
(harness-log "GATE [Perceive]: Act Result -> ~a"
(getf payload :status))))
;; Update signal status
(setf (getf signal :status) :perceived)
(setf (getf signal :foveal-focus) *foveal-focus-id*)
signal))

View File

@@ -1,33 +1,86 @@
(in-package :opencortex)
(defvar *probabilistic-backends* (make-hash-table :test 'equal))
(defvar *provider-cascade* nil)
(defvar *model-selector-fn* nil)
(defvar *consensus-enabled-p* nil)
(defvar *probabilistic-backends* (make-hash-table :test 'equal)
"Registry mapping provider keywords (:openrouter, :ollama) to their calling functions.")
(defvar *provider-cascade* nil
"Ordered list of provider keywords to try. First available provider wins.")
(defvar *model-selector-fn* nil
"Optional function that selects a specific model for each provider.
Signature: (funcall fn provider context) => model-name-string")
(defvar *consensus-enabled-p* nil
"When T, run multiple providers and compare results for critical decisions.")
(defun register-probabilistic-backend (name fn)
"Registers a neural provider (e.g., :gemini, :anthropic) with its calling function."
"Register a neural provider backend.
NAME is a keyword like :openrouter or :ollama.
FN is a function with signature: (funcall fn prompt system-prompt &key model)
returning either:
- (list :status :success :content \"response text\")
- (list :status :error :message \"error description\")
- a simple string on success
Example registration:
(register-probabilistic-backend :openrouter #'openrouter-call)"
(setf (gethash name *probabilistic-backends*) fn))
(defun probabilistic-call (prompt &key (system-prompt "You are the Probabilistic engine.") (cascade nil) (context nil))
"Dispatches a neural request through the provider cascade. Returns a Lisp plist or a failure log."
(defun probabilistic-call (prompt &key
(system-prompt "You are the Probabilistic engine.")
(cascade nil)
(context nil))
"Dispatch a neural request through the provider cascade.
PROMPT - The user's query or task description.
SYSTEM-PROMPT - Instructions for how the LLM should behave.
CASCADE - Override the default provider cascade.
CONTEXT - Current signal context (for model selection).
Returns the LLM response as a string, or a failure plist if all providers fail.
The cascade mechanism ensures reliability: if OpenRouter is rate-limited,
it automatically falls back to OpenAI, then Anthropic, etc."
(let ((backends (or cascade *provider-cascade*)))
(or (dolist (backend backends)
(let ((backend-fn (gethash backend *probabilistic-backends*)))
(when backend-fn
(harness-log "PROBABILISTIC: Attempting backend ~a..." backend)
(let* ((model (when *model-selector-fn* (funcall *model-selector-fn* backend context)))
(result (if model
;; Optional model selection based on context
(let* ((model (when *model-selector-fn*
(funcall *model-selector-fn* backend context)))
(result (if model
(funcall backend-fn prompt system-prompt :model model)
(funcall backend-fn prompt system-prompt))))
;; Normalize result format
(cond ((and (listp result) (eq (getf result :status) :success))
(return (getf result :content)))
((stringp result) (return result))
(t (harness-log "PROBABILISTIC: Backend ~a failed: ~a" backend (getf result :message))))))))
(list :type :LOG :payload (list :text "Neural Cascade Failure: All providers exhausted.")))))
((stringp result)
(return result))
(t
(harness-log "PROBABILISTIC: Backend ~a failed: ~a"
backend (getf result :message))))))))
;; All providers failed
(list :type :LOG
:payload (list :text "Neural Cascade Failure: All providers exhausted.")))))
(defun strip-markdown (text)
"Strips common markdown code block markers from text."
"Strip markdown formatting from LLM output.
LLMs often wrap their responses in code fences (```lisp ...```).
This function removes those markers to extract the raw plist.
Handles:
- Leading code fences with language tags: ```lisp
- Trailing code fences: ```
- Orphan closing fences: ```"
(if (and text (stringp text))
(let ((cleaned text))
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
@@ -37,7 +90,18 @@
text))
(defun normalize-plist-keywords (plist)
"Normalize all keys in a plist to keywords (e.g., TYPE -> :TYPE)."
"Normalize all keys in a plist to keywords.
LLMs often return plists with unquoted keys: (TYPE REQUEST ...)
instead of keyword syntax: (:TYPE :REQUEST ...)
This function converts all symbol keys to their keyword equivalents,
making the plist compatible with standard Lisp property accessors.
Example transformation:
(TYPE REQUEST PAYLOAD (ACTION MESSAGE TEXT \"Hi\"))
=> (:TYPE :REQUEST :PAYLOAD (:ACTION :MESSAGE :TEXT \"Hi\"))"
(when (listp plist)
(loop for (k . rest) on plist by #'cddr
collect (if (and (symbolp k) (not (keywordp k)))
@@ -46,88 +110,252 @@
collect (car rest))))
(defun think (context)
"Generates a Lisp action proposal based on current context."
"Generate a Lisp action proposal based on current context.
This is the core cognitive function. It:
1. Finds the most relevant skill based on context
2. Assembles global awareness (memory context, system logs)
3. Constructs a detailed prompt with available tools
4. Calls the LLM via probabilistic-call
5. Parses the LLM response into a structured action plist
The LLM is instructed to respond with exactly ONE plist, never prose.
This constraint makes parsing deterministic and prevents rambling.
Returns a plist with structure:
(:TYPE :REQUEST :TARGET :CLI :PAYLOAD (:ACTION :MESSAGE :TEXT \"...\"))"
;; Gather context components
(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")))
(let* ((prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
(raw-prompt (if prompt-generator
;; Generate prompt from skill or raw text
(let* ((prompt-generator (when active-skill
(skill-probabilistic-prompt active-skill)))
(raw-prompt (if prompt-generator
(funcall prompt-generator context)
;; Fallback: use raw user input
(let ((p (proto-get (proto-get context :payload) :text)))
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
(system-prompt (format nil "IDENTITY: ~a. MANDATE: Respond with ONE Lisp plist. ~a ~a RECENT_LOGS: ~a
(if (and p (stringp p))
p
"Maintain metabolic stasis."))))
(system-prompt (format nil
"IDENTITY: ~a
You are a component of the OpenCortex neurosymbolic AI agent.
Your task is to generate exactly ONE valid Lisp plist response.
MANDATE: Respond with ONE Lisp plist. Never output prose.
IMPORTANT: To reply to the user, you MUST use:
(:TYPE :REQUEST :PAYLOAD (:ACTION :MESSAGE :TEXT \"<Response Text>\"))
To call a tool, you MUST use:
(:TYPE :REQUEST :TARGET :TOOL :ACTION :CALL :TOOL \"<name>\" :ARGS (:arg1 \"val\"))
MANDATORY VALIDATION RULE: Before declaring any Lisp code edit complete, you MUST call the `:validate-lisp` tool with the proposed code. If the tool returns `:status :error`, read the `:reason` and `:failed` fields, fix the defect, and re-validate. You are strictly forbidden from relying on your own paren-balancing or syntax intuition.
MANDATORY VALIDATION RULE: Before declaring any Lisp code edit complete,
you MUST call the `:validate-lisp` tool with the proposed code. If the tool
returns `:status :error`, read the `:reason` and `:failed` fields, fix the
defect, and re-validate. You are strictly forbidden from relying on your
own paren-balancing or syntax intuition.
PROVIDER RULE: Always use the default cascade provider unless a specific model or capability is required for the task."
assistant-name global-context tool-belt system-logs)))
(let* ((thought (probabilistic-call raw-prompt :system-prompt system-prompt :context context))
PROVIDER RULE: Always use the default cascade provider unless a specific
model or capability is required for the task.
AVAILABLE TOOLS:
~a
GLOBAL CONTEXT:
~a
RECENT LOGS:
~a"
assistant-name
tool-belt
global-context
system-logs)))
;; Call LLM and process response
(let* ((thought (probabilistic-call raw-prompt
:system-prompt system-prompt
:context context))
(cleaned (strip-markdown thought))
(meta (proto-get context :meta))
(source (proto-get meta :source)))
(harness-log "THINK: raw cleaned = ~a" (subseq cleaned 0 (min 100 (length cleaned))))
(if (and cleaned (stringp cleaned))
(when cleaned
(harness-log "THINK: LLM raw output = ~a"
(subseq cleaned 0 (min 200 (length cleaned)))))
;; Parse LLM response
(if (and cleaned (stringp cleaned) (> (length cleaned) 0))
(let ((*read-eval* nil))
(if (and (> (length cleaned) 0) (char= (char cleaned 0) #\())
(handler-case
(if (char= (char cleaned 0) #\()
;; Response starts with paren - try to parse as plist
(handler-case
(let ((parsed (read-from-string cleaned)))
(harness-log "THINK: parsed = ~a" parsed)
(let ((parsed-normalized (normalize-plist-keywords parsed))
(type (proto-get parsed :TYPE))
(target (or (proto-get parsed :TARGET) (proto-get parsed :target))))
(cond ((member type '(:REQUEST :EVENT :STATUS :RESPONSE))
(unless (proto-get parsed :target) (setf (getf parsed :target) (or source :CLI)))
parsed-normalized)
((or (eq target :TOOL) (eq target :tool) (getf parsed :TOOL) (getf parsed :tool)
(and (listp parsed) (listp (car parsed)) (keywordp (caar parsed))))
(list :TYPE :REQUEST :TARGET :TOOL :PAYLOAD (normalize-plist-keywords parsed)))
(t (list :TYPE :REQUEST :TARGET (or source :CLI) :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))))
(error (c) (harness-log "THINK ERROR: ~a" c) (list :TYPE :REQUEST :TARGET (or source :CLI) :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))
(list :TYPE :REQUEST :TARGET (or source :CLI) :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))
(when parsed
(harness-log "THINK: parsed = ~a" parsed)
;; Normalize keyword keys (LLM often returns TYPE instead of :TYPE)
(let ((parsed-normalized (normalize-plist-keywords parsed))
(type (proto-get parsed :TYPE))
(target (or (proto-get parsed :TARGET)
(proto-get parsed :target))))
(cond
;; Recognized message type - use directly
((member type '(:REQUEST :EVENT :STATUS :RESPONSE))
(unless (proto-get parsed :target)
(setf (getf parsed :target) (or source :CLI)))
parsed-normalized)
;; Tool call detected - wrap in standard envelope
((or (eq target :TOOL)
(eq target :tool)
(getf parsed :TOOL)
(getf parsed :tool)
(and (listp parsed)
(listp (car parsed))
(keywordp (caar parsed))))
(list :TYPE :REQUEST
:TARGET :TOOL
:PAYLOAD (normalize-plist-keywords parsed)))
;; Unknown format - treat as user message
(t
(list :TYPE :REQUEST
:TARGET (or source :CLI)
:PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned)))))))
(error (c)
(harness-log "THINK ERROR: ~a" c)
(list :TYPE :REQUEST
:TARGET (or source :CLI)
:PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))
;; No leading paren - treat as plain text message
(list :TYPE :REQUEST
:TARGET (or source :CLI)
:PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))
;; No response from LLM
thought)))))
(defun deterministic-verify (proposed-action context)
"Iterates through all skill deterministic-gates sorted by priority."
"Run all skill deterministic gates on a proposed action.
Each skill can define a deterministic function that either:
- Passes the action through unchanged
- Modifies the action (adds explanation, changes target, etc.)
- Blocks the action (returns a :LOG message instead)
Skills are sorted by priority (highest first). A skill with higher
priority can intercept and modify actions before lower-priority
skills see them.
The Bouncer Pattern: If any skill returns a :LOG or :EVENT type,
processing stops and that message is returned immediately. This
allows skills to veto actions.
Example skill chain:
1. Policy skill (priority 500) - checks for missing explanations
2. Protocol validator (priority 95) - validates message schema
3. Shell actuator guard (priority 50) - checks command whitelist"
(let ((current-action proposed-action)
(skills nil))
(maphash (lambda (name skill) (declare (ignore name)) (when (skill-deterministic-fn skill) (push skill skills))) *skills-registry*)
;; Collect all skills with deterministic functions
(maphash (lambda (name skill)
(declare (ignore name))
(when (skill-deterministic-fn skill)
(push skill skills)))
*skills-registry*)
;; Sort by priority (highest first)
(setf skills (sort skills #'> :key #'skill-priority))
;; Run each skill's gate
(dolist (skill skills)
(let ((trigger (skill-trigger-fn skill))
(gate (skill-deterministic-fn skill)))
(when (or (null trigger) (ignore-errors (funcall trigger context)))
;; Skill activates if no trigger or trigger returns true
(when (or (null trigger)
(ignore-errors (funcall trigger context)))
;; Run the gate
(let ((next-action (funcall gate current-action context)))
(let ((original-type (proto-get current-action :type)))
(when (and (listp next-action)
(member (proto-get next-action :type) '(:LOG :EVENT :log :event))
;; Check if skill intercepted (returned LOG/EVENT instead of REQUEST)
(when (and (listp next-action)
(member (proto-get next-action :type)
'(:LOG :EVENT :log :event))
(or (not (member original-type '(:LOG :EVENT :log :event)))
(not (eq next-action current-action))))
(harness-log "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill))
;; Skill blocked or modified - stop processing
(harness-log "DETERMINISTIC: Intercepted by skill '~a'"
(skill-name skill))
(return-from deterministic-verify next-action)))
;; Action passed through - continue to next skill
(setf current-action next-action)))))
;; Return final action (may be modified by skills, or original if all passed)
current-action))
(defun reason-gate (signal)
"Unified Stage: Combines Probabilistic proposals and Deterministic verification."
"Stage 2 of the metabolic pipeline: Reason.
Transforms perceived signals into approved actions by combining:
1. Probabilistic reasoning (LLM generates proposal)
2. Deterministic verification (skills validate proposal)
Only processes :EVENT signals with :user-input or :chat-message sensors.
Other signals pass through unchanged (heartbeats, tool outputs, etc.).
Modifies the signal in place by setting:
- :approved-action - The final verified action, or NIL
- :status - :reasoned
Returns the modified 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)))
;; Only reason about user input, not internal signals
(unless (and (eq type :EVENT)
(member sensor '(:user-input :chat-message)))
(return-from reason-gate signal))
;; Generate proposal via LLM
(let ((candidate (think signal)))
(harness-log "REASON: candidate = ~a" (type-of candidate))
(if (and candidate (listp candidate)
(or (keywordp (car candidate)) (eq (car candidate) 'TYPE) (eq (car candidate) 'type)))
(setf (getf signal :approved-action) (deterministic-verify candidate signal))
(harness-log "REASON: candidate type = ~a" (type-of candidate))
;; Validate candidate is a proper plist (not an error string or symbol)
(if (and candidate
(listp candidate)
(or (keywordp (car candidate))
(eq (car candidate) 'TYPE)
(eq (car candidate) 'type)))
;; Valid proposal - run through deterministic verification
(setf (getf signal :approved-action)
(deterministic-verify candidate signal))
;; Invalid response - log and drop
(progn
(harness-log "REASON: Invalid candidate type ~a, dropping" (type-of candidate))
(harness-log "REASON: Invalid candidate type ~a, dropping"
(type-of candidate))
(setf (getf signal :approved-action) nil)))
(setf (getf signal :status) :reasoned)
signal)))

View File

@@ -173,9 +173,9 @@ Only loads blocks that specify a .lisp tangle target, ignoring tests and example
(search ".lisp" tl)
(not (search "tests/" tl))
(not (search "test/" tl))))))
((uiop:string-prefix-p "#+end_src" (string-downcase clean-line))
(setf in-lisp-block nil)
(setf collect-this-block nil))
((uiop:string-prefix-p "#+end" (string-downcase clean-line))
(setf in-lisp-block nil)
(setf collect-this-block nil))
((and in-lisp-block collect-this-block)
(unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line))
(uiop:string-prefix-p ":END:" (string-upcase clean-line)))
@@ -322,43 +322,108 @@ EXAMPLES:
(uiop:run-program (list "bash" "-c" cmd) :output :string :error-output :string :ignore-error-status t)
(format nil "EXIT-CODE: ~a~%~%STDOUT:~%~a~%~%STDERR:~%~a" code out err)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(def-cognitive-tool :reload-skill "Reloads a skill from its Org-mode source file."
((:skill :type :string :description "The skill name"))
:guard (lambda (args context)
(declare (ignore context))
(let ((skill (getf args :skill)))
(or (uiop:file-exists-p skill)
(let ((dir (or (ignore-errors (uiop:getenv "SKILLS_DIR"))
(namestring (user-homedir-pathname)))))
(uiop:file-exists-p (merge-pathnames (format nil "~a.org" skill) dir))))))
:body (lambda (args)
(let ((skill (getf args :skill))
(dir (or (ignore-errors (uiop:getenv "SKILLS_DIR"))
(namestring (user-homedir-pathname)))))
(let ((file (merge-pathnames (format nil "~a.org" skill) (uiop:ensure-directory-pathname dir))))
(if (uiop:file-exists-p file)
(format nil "OK: skill ~a found" skill)
(format nil "ERROR: skill ~a not found" skill))))))
(def-cognitive-tool :reload-skill "Reloads a skill from its Org-mode source file, recompiling into the live image without restarting the daemon."
((:skill :type :string :description "The skill name (e.g., \"org-skill-policy\") or full path to the .org file"))
:guard (lambda (args context)
(declare (ignore context))
(let ((skill (getf args :skill)))
(or (uiop:file-exists-p skill)
(let ((skills-dir (or (ignore-errors (uiop:getenv "SKILLS_DIR"))
(namestring (merge-pathnames "notes/" (user-homedir-pathname))))))
(uiop:file-exists-p (merge-pathnames (format nil "~a.org" skill) skills-dir))))))
:body (lambda (args)
(let ((skill (getf args :skill)))
(snapshot-memory)
(let ((skills-dir (or (ignore-errors (uiop:getenv "SKILLS_DIR"))
(namestring (merge-pathnames "notes/" (user-homedir-pathname)))))
(resolved-path (context-resolve-path skills-dir))
(skills-dir-actual (if (ignore-errors (uiop:getenv "SKILLS_DIR"))
(uiop:ensure-directory-pathname (context-resolve-path (uiop:getenv "SKILLS_DIR")))
(uiop:ensure-directory-pathname (user-homedir-pathname)))))
(let ((file (if (uiop:file-exists-p skill)
(uiop:ensure-pathname skill)
(merge-pathnames (format nil "~a.org" skill) skills-dir-actual))))
(cond
((not (uiop:file-exists-p file))
(format nil "ERROR: Skill file not found: ~a" (uiop:native-namestring file)))
(t
(harness-log "SKILL: Hot-reloading ~a..." (pathname-name file))
(let ((status (load-skill-with-timeout file 10)))
(if (eq status :success)
(let ((base-name (pathname-name file)))
(setf (skill-entry-status (gethash base-name *skill-catalog*)) :ready)
(format nil "OK: Skill '~a' reloaded successfully." base-name))
(format nil "ERROR: Reload failed with status ~a" status))))))))))
(def-cognitive-tool :read-File "Reads the contents of a file."
((:file :type :string))
:body (lambda (args)
(uiop:read-file-string (getf args :file))))
(def-cognitive-tool :read-file "Reads the contents of a file as a string."
((:file :type :string :description "The path to the file to read"))
:guard (lambda (args context)
(declare (ignore context))
(let* ((file (getf args :file))
(memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex"))
(truename (ignore-errors (namestring (truename file)))))
(or (null truename)
(str:starts-with-p memex-root truename))))
:body (lambda (args)
(let ((file (getf args :file)))
(handler-case
(uiop:read-file-string file)
(error (c)
(format nil "ERROR reading ~a: ~a" file c))))))
(def-cognitive-tool :write-file "Writes content to a file."
((:file :type :string) (:content :type :string))
:body (lambda (args)
(with-open-file (out (getf args :file) :direction :output :if-exists :supersede)
(write-string (getf args :content) out))
"OK"))
(def-cognitive-tool :write-file "Writes content to a file, creating it if it doesn't exist."
((:file :type :string :description "The path to the file to write")
(:content :type :string :description "The content to write")
(:append :type :string :description "\"t\" to append instead of overwriting (optional)"))
:guard (lambda (args context)
(declare (ignore context))
(let* ((file (getf args :file))
(memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex"))
(truename (ignore-errors (namestring (truename file)))))
(or (null truename)
(str:starts-with-p memex-root truename))))
:body (lambda (args)
(let ((file (getf args :file))
(content (getf args :content))
(append-p (string-equal (getf args :append) "t")))
(handler-case
(progn
(snapshot-memory)
(with-open-file (out file
:direction :output
:if-exists (if append-p :append :supersede)
:if-does-not-exist :create)
(write-string content out))
(format nil "OK: ~a written to ~a"
(if append-p "content appended" "file written")
file))
(error (c)
(format nil "ERROR writing ~a: ~a" file c))))))
(def-cognitive-tool :replace-string "Replaces text in a file."
((:file :type :string) (:old :type :string) (:new :type :string))
:body (lambda (args)
(let ((content (uiop:read-file-string (getf args :file))))
(setf content (cl-ppcre:regex-replace-all (cl-ppcre:quote-meta-chars (getf args :old)) content (getf args :new)))
(with-open-file (out (getf args :file) :direction :output :if-exists :supersede)
(write-string content out))
"OK")))
)
(def-cognitive-tool :replace-string "Replaces occurrences of old-string with new-string in a file."
((:file :type :string :description "The path to the file")
(:old :type :string :description "The substring to find and replace")
(:new :type :string :description "The replacement string"))
:guard (lambda (args context)
(declare (ignore context))
(let* ((file (getf args :file))
(memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex"))
(truename (ignore-errors (namestring (truename file)))))
(or (null truename)
(str:starts-with-p memex-root truename))))
:body (lambda (args)
(let ((file (getf args :file))
(old (getf args :old))
(new (getf args :new)))
(handler-case
(progn
(snapshot-memory)
(let ((content (uiop:read-file-string file)))
(if (search old content)
(let ((new-content (cl-ppcre:regex-replace-all (cl-ppcre:quote-meta-chars old) content new)))
(with-open-file (out file :direction :output :if-exists :supersede)
(write-string new-content out))
(format nil "OK: Replaced first occurrence in ~a" file))
(format nil "ERROR: Pattern not found in ~a" file))))
(error (c)
(format nil "ERROR replacing in ~a: ~a" file c))))))

View File

@@ -19,18 +19,16 @@
:serial t ; Load files in order listed below
:components ((:file "library/package") ; Package definitions, core vars
(:file "library/skills") ; Skill engine, cognitive tools
(:file "library/communication") ; Protocol, framing
(:file "library/communication-validator") ; Schema validation
(:file "library/memory") ; Org-object store, snapshots
(:file "library/gen/org-skill-engineering-standards") ; Enforcement
(:file "library/gen/org-skill-literate-programming") ; LP enforcement
(:file "library/context") ; Context assembly, query
(:file "library/perceive") ; Stage 1: Sensory normalization
(:file "library/reason") ; Stage 2: Neural + deterministic
(:file "library/act") ; Stage 3: Actuation
(:file "library/loop")) ; Main entry, heartbeat
:components ((:file "library/package") ; Package definitions, core vars
(:file "library/skills") ; Skill engine, cognitive tools
(:file "library/communication") ; Protocol, framing
(:file "library/communication-validator") ; Schema validation
(:file "library/memory") ; Org-object store, snapshots
(:file "library/context") ; Context assembly, query
(:file "library/perceive") ; Stage 1: Sensory normalization
(:file "library/reason") ; Stage 2: Neural + deterministic
(:file "library/act") ; Stage 3: Actuation
(:file "library/loop")) ; Main entry, heartbeat
:build-operation "program-op"
:build-pathname "opencortex-server"
@@ -40,40 +38,42 @@
:depends-on (:opencortex ; The harness we're testing
:fiveam) ; Testing framework
:components ((:file "library/gen/org-skill-emacs-edit")
(:file "library/gen/org-skill-lisp-utils")
(:file "library/gen/org-skill-tool-permissions")
(:file "tests/communication-tests")
(:file "tests/pipeline-tests")
(:file "tests/act-tests")
(:file "tests/boot-sequence-tests")
(:file "tests/memory-tests")
(:file "tests/immune-system-tests")
(:file "tests/emacs-edit-tests")
(:file "tests/lisp-utils-tests")
(:file "tests/tool-permissions-tests")
(:file "tests/engineering-standards-tests")
(:file "tests/literate-programming-tests"))
:components ((:file "library/gen/org-skill-engineering-standards")
(:file "library/gen/org-skill-literate-programming")
(:file "library/gen/org-skill-self-edit")
(:file "library/gen/org-skill-emacs-edit")
(:file "library/gen/org-skill-lisp-utils")
(:file "tests/engineering-standards-tests")
(:file "tests/literate-programming-tests")
(:file "tests/pipeline-perceive-tests")
(:file "tests/pipeline-reason-tests")
(:file "tests/pipeline-act-tests")
(:file "tests/act-tests")
(:file "tests/boot-sequence-tests")
(:file "tests/memory-tests")
(:file "tests/immune-system-tests")
(:file "tests/emacs-edit-tests")
(:file "tests/lisp-utils-tests")
(:file "tests/lisp-validator-tests")
(:file "tests/self-edit-tests")
(:file "tests/tool-permissions-tests")
(:file "tests/peripheral-vision-tests"))
:perform (test-op (o s)
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :communication-protocol-suite :opencortex-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :pipeline-suite :opencortex-pipeline-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :boot-suite :opencortex-boot-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :memory-suite :opencortex-memory-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :immune-suite :opencortex-immune-system-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :emacs-edit-suite :opencortex-emacs-edit-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :lisp-utils-suite :opencortex-lisp-utils-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :engineering-standards-suite :opencortex-engineering-standards-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :literate-programming-suite :opencortex-literate-programming-tests))))
:perform (test-op (o s)
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :communication-protocol-suite :opencortex-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :pipeline-suite :opencortex-pipeline-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :boot-suite :opencortex-boot-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :memory-suite :opencortex-memory-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :immune-suite :opencortex-immune-system-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :emacs-edit-suite :opencortex-emacs-edit-tests))
(uiop:symbol-call :fiveam :run!
(uiop:find-symbol* :lisp-utils-suite :opencortex-lisp-utils-tests))))
(defsystem :opencortex/tui
:depends-on (:opencortex ; The daemon we're connecting to

View File

@@ -6,24 +6,45 @@
:dexador :jonathan :cl-dotenv :hunchentoot
:trivial-garbage :s-sql :str :uuid :cl-json :uiop :fiveam))
(load "library/package.lisp")
(load "library/skills.lisp")
(load "library/communication.lisp")
(load "library/communication-validator.lisp")
(load "library/memory.lisp")
(load "library/gen/org-skill-engineering-standards.lisp")
(load "library/gen/org-skill-literate-programming.lisp")
(load "library/context.lisp")
(load "library/perceive.lisp")
(load "library/reason.lisp")
(load "library/act.lisp")
(load "library/loop.lisp")
(asdf:load-system :opencortex)
(asdf:load-system :opencortex/tests)
(format t "~%=== Running ALL Test Suites ===~%")
;; Engineering Standards tests
(when (find-package :OPENCORTEX-ENGINEERING-STANDARDS-TESTS)
(fiveam:run! 'OPENCORTEX-ENGINEERING-STANDARDS-TESTS::ENGINEERING-STANDARDS-SUITE))
;; Literate Programming tests
(when (find-package :OPENCORTEX-LITERATE-PROGRAMMING-TESTS)
(fiveam:run! 'OPENCORTEX-LITERATE-PROGRAMMING-TESTS::LITERATE-PROGRAMMING-SUITE))
(format t "~%=== ALL TESTS COMPLETE ===~%")
;; Communication tests
(when (find-package :OPENCORTEX-TESTS)
(fiveam:run! 'OPENCORTEX-TESTS::COMMUNICATION-PROTOCOL-SUITE))
;; Pipeline tests
(when (find-package :OPENCORTEX-PIPELINE-TESTS)
(fiveam:run! 'OPENCORTEX-PIPELINE-TESTS::PIPELINE-SUITE))
;; Boot sequence tests
(when (find-package :OPENCORTEX-BOOT-TESTS)
(fiveam:run! 'OPENCORTEX-BOOT-TESTS::BOOT-SUITE))
;; Memory tests
(when (find-package :OPENCORTEX-MEMORY-TESTS)
(fiveam:run! 'OPENCORTEX-MEMORY-TESTS::MEMORY-SUITE))
;; Immune system tests
(when (find-package :OPENCORTEX-IMMUNE-SYSTEM-TESTS)
(fiveam:run! 'OPENCORTEX-IMMUNE-SYSTEM-TESTS::IMMUNE-SUITE))
;; Emacs edit tests
(when (find-package :OPENCORTEX-EMACS-EDIT-TESTS)
(fiveam:run! 'OPENCORTEX-EMACS-EDIT-TESTS::EMACS-EDIT-SUITE))
;; Lisp utils tests
(when (find-package :OPENCORTEX-LISP-UTILS-TESTS)
(fiveam:run! 'OPENCORTEX-LISP-UTILS-TESTS::LISP-UTILS-SUITE))
(format t "~%=== ALL TESTS COMPLETE ===~%")

View File

@@ -404,7 +404,7 @@ Use this AFTER modifications to save changes."
(let ((id1 (emacs-edit-generate-id))
(id2 (emacs-edit-generate-id)))
(is (plusp (length id1)))
(is (not (string= id1 id2)))) ;; Likely unique
(is (not (string= id1 id2))))) ;; Likely unique
(test id-format
(let ((formatted (emacs-edit-id-format "abc12345")))

View File

@@ -161,6 +161,74 @@ Provide a fixed version of the code as a lisp form.")
(list :status :error :message (format nil "Could not repair: ~a" c)))))))
#+end_src
** Skill Hot-Reload
Swap compiled skill files without breaking active sockets.
#+begin_src lisp :tangle ../library/gen/org-skill-self-edit.lisp
(defvar *self-edit-skills-backup* nil
"Backup of skill registry before hot-reload.")
(defun self-edit-hot-reload-skill (skill-name gen-path)
"Reloads a skill from its compiled .lisp source.
Steps:
1. Backup current *skills-registry*
2. Compile the new skill file
3. Merge new skill into registry
4. Verify the skill loads without error
5. If error, rollback to backup
Returns (values :success t) or (values :error message)."
(unless *skills-registry*
(return-from self-edit-hot-reload-skill
(values :error "Skills engine not initialized")))
(unless (uiop:file-exists-p gen-path)
(return-from self-edit-hot-reload-skill
(values :error (format nil "Skill file not found: ~a" gen-path))))
;; Step 1: Backup registry
(setf *self-edit-skills-backup* (copy-hash-table *skills-registry*))
(handler-case
(progn
;; Step 2: Compile new skill
(let ((compiled (compile-file gen-path)))
(unless compiled
(error "Compilation returned nil")))
;; Step 3: Load the compiled skill
(load gen-path)
;; Step 4: Verify skill is in registry
(let ((skill (gethash (string skill-name) *skills-registry*)))
(if skill
(progn
(harness-log "SELF-EDIT: Hot-reloaded skill ~a from ~a"
skill-name gen-path)
(values :success t))
(error "Skill not registered after reload"))))
(error (e)
;; Step 5: Rollback
(when *self-edit-skills-backup*
(clrhash *skills-registry*)
(maphash (lambda (k v) (setf (gethash k *skills-registry*) v))
*self-edit-skills-backup*))
(harness-log "SELF-EDIT: Hot-reload FAILED for ~a: ~a" skill-name e)
(values :error (format nil "Hot-reload failed: ~a" e)))))
#+end_src
** Cognitive Tool: Reload Skill
#+begin_src lisp :tangle ../library/gen/org-skill-self-edit.lisp
(def-cognitive-tool :reload-skill
"Hot-reloads a skill from its compiled source file without restarting the system."
((:skill-name :type :string :description "Name of the skill to reload (e.g. :skill-engineering-standards)")
(:gen-path :type :string :description "Absolute path to the compiled .lisp file"))
:body (lambda (args)
(let ((name (getf args :skill-name))
(path (getf args :gen-path)))
(multiple-value-bind (status message) (self-edit-hot-reload-skill name path)
(list :status status :message message)))))
#+end_src
* Phase E: Verification
#+begin_src lisp :tangle ../tests/self-edit-tests.lisp
@@ -176,27 +244,27 @@ Provide a fixed version of the code as a lisp form.")
(in-suite self-edit-suite)
(test balance-parens-balanced
(let ((result (opencortex:self-edit-balance-parens "(+ 1 2)")))
(let ((result (opencortex::self-edit-balance-parens "(+ 1 2)")))
(is (string= result "(+ 1 2)"))
(is (not (null (read-from-string result))))))
(test balance-parens-missing-open
(let ((result (opencortex:self-edit-balance-parens "+ 1 2)")))
(let ((result (opencortex::self-edit-balance-parens "+ 1 2)")))
(is (string= result "(+ 1 2)"))
(is (not (null (read-from-string result))))))
(test balance-parens-missing-close
(let ((result (opencortex:self-edit-balance-parens "(+ 1 2")))
(let ((result (opencortex::self-edit-balance-parens "(+ 1 2")))
(is (string= result "(+ 1 2)"))
(is (not (null (read-from-string result))))))
(test balance-parens-deep
(let ((result (opencortex:self-edit-balance-parens "((lambda (x) (if x (+ 1 2) 3))")))
(let ((result (opencortex::self-edit-balance-parens "((lambda (x) (if x (+ 1 2) 3))")))
(is (string= result "((lambda (x) (if x (+ 1 2) 3)))"))
(is (not (null (read-from-string result))))))
(test balance-parens-empty
(let ((result (opencortex:self-edit-balance-parens "")))
(let ((result (opencortex::self-edit-balance-parens "")))
(is (string= result ""))))
#+end_src

View File

@@ -0,0 +1,47 @@
(defpackage :opencortex-boot-tests
(:use :cl :fiveam :opencortex)
(:export #:boot-suite))
(in-package :opencortex-boot-tests)
(def-suite boot-suite :description "Verification of the Skill Engine loader")
(in-suite boot-suite)
(test test-parse-skill-metadata
"Verify extraction of ID and DEPENDS_ON from Org headers."
(let ((tmp-file "/tmp/org-skill-test-metadata.org"))
(with-open-file (out tmp-file :direction :output :if-exists :supersede)
(format out ":PROPERTIES:~%:ID: test-id~%:END:~%#+DEPENDS_ON: dep1 dep2~%"))
(unwind-protect
(multiple-value-bind (id deps) (opencortex::parse-skill-metadata tmp-file)
(is (equal "test-id" id))
(is (member "dep1" deps :test #'string=))
(is (member "dep2" deps :test #'string=)))
(uiop:delete-file-if-exists tmp-file))))
(test test-topological-sort-basic
"Verify that skills are ordered by dependency."
(let ((tmp-dir "/tmp/opencortex-boot-test/"))
(uiop:ensure-all-directories-exist (list tmp-dir))
(with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede)
(format out "#+DEPENDS_ON: skill-b-id~%"))
(with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede)
(format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%"))
(unwind-protect
(let ((sorted (opencortex::topological-sort-skills tmp-dir)))
(let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal))
(pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal)))
(is (< pos-b pos-a)))
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
(test test-skill-jailing
"Verify that skills are loaded into their own packages."
(let ((tmp-skill "/tmp/org-skill-jail-test.org"))
(with-open-file (out tmp-skill :direction :output :if-exists :supersede)
(format out ":PROPERTIES:~%:ID: jail-test-id~%:END:~%#+TITLE: Jail Test Skill~%#+begin_src lisp :tangle no~(defun jail-test-fn () t)~#+end_src"))
(unwind-protect
(progn
(opencortex::load-skill-from-org tmp-skill)
(is (not (null (gethash "org-skill-jail-test" opencortex::*skills-registry*)))))
(uiop:delete-file-if-exists tmp-skill)))))

View File

@@ -13,7 +13,7 @@
(let ((id1 (emacs-edit-generate-id))
(id2 (emacs-edit-generate-id)))
(is (plusp (length id1)))
(is (not (string= id1 id2)))))
(is (not (string= id1 id2))))) ;; Likely unique
(test id-format
(let ((formatted (emacs-edit-id-format "abc12345")))
@@ -31,4 +31,4 @@
:properties (list :ID "id:todo001" :TITLE "Task")
:contents nil)))
(emacs-edit-set-todo ast "id:todo001" "DONE")
(is (string= (getf (getf ast :properties) :TODO) "DONE"))))
(is (string= (getf (getf ast :properties) :TODO) "DONE"))))

View File

@@ -0,0 +1,23 @@
(defpackage :opencortex-immune-system-tests
(:use :cl :fiveam :opencortex)
(:export #:immune-suite))
(in-package :opencortex-immune-system-tests)
(def-suite immune-suite
:description "Verification of the Immune System (Core Error Hooks)")
(in-suite immune-suite)
(test loop-error-injection
"Verify that a crash in think/decide triggers a :loop-error stimulus."
(clrhash opencortex::*skills-registry*)
(opencortex:defskill :evil-skill
:priority 100
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input))
:probabilistic (lambda (ctx) (error "CRITICAL BRAIN FAILURE"))
:deterministic nil)
(opencortex:harness-log "CLEAN LOG")
(opencortex:process-signal '(:type :EVENT :payload (:sensor :user-input)))
(let ((logs (opencortex:context-get-system-logs 20)))
(is (not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs))))))

View File

@@ -94,8 +94,3 @@
(let ((result (opencortex::lisp-utils-validate "(delete-file \"x.txt\")" :strict t)))
(is (eq (getf result :status) :error))
(is (eq (getf result :failed) :semantic))))
(test unified-semantic-fail
(let ((result (opencortex::lisp-utils-validate "(delete-file \"x.txt\")" :strict t)))
(is (eq (getf result :status) :error))
(is (eq (getf result :failed) :semantic))))

View File

@@ -0,0 +1,54 @@
(defpackage :opencortex-lisp-validator-tests
(:use :cl :fiveam :opencortex)
(:export #:lisp-validator-suite))
(in-package :opencortex-lisp-validator-tests)
(def-suite lisp-validator-suite
:description "Tests for the Lisp Validator structural, syntactic, and semantic gates")
(in-suite lisp-validator-suite)
(test structural-balanced
(let ((result (opencortex::lisp-validator-check-structural "(+ 1 2)")))
(is (eq result t))))
(test structural-unbalanced-open
(multiple-value-bind (ok reason line col)
(opencortex::lisp-validator-check-structural "(+ 1 2")
(is (null ok))
(is (search "Unbalanced" reason))))
(test structural-unbalanced-close
(multiple-value-bind (ok reason line col)
(opencortex::lisp-validator-check-structural "+ 1 2)")
(is (null ok))
(is (search "Unbalanced" reason))))
(test syntactic-valid
(multiple-value-bind (ok reason line col)
(opencortex::lisp-validator-check-syntactic "(+ 1 2)")
(is (eq ok t))))
(test syntactic-invalid-reader
(multiple-value-bind (ok reason line col)
(opencortex::lisp-validator-check-syntactic "(1+ 2 #\")")
(is (not ok))))
(test semantic-safe
(multiple-value-bind (ok reason line col)
(opencortex::lisp-validator-check-semantic "(+ 1 2)")
(is (eq ok t))))
(test semantic-blocked-eval
(multiple-value-bind (ok reason line col)
(opencortex::lisp-validator-check-semantic "(eval '(+ 1 2))")
(is (not ok))))
(test unified-success
(let ((result (opencortex::lisp-validator-validate "(+ 1 2)" :strict t)))
(is (eq (getf result :status) :success))))
(test unified-failure
(let ((result (opencortex::lisp-validator-validate "(+ 1 2" :strict nil)))
(is (eq (getf result :status) :error))))

115
tests/memory-tests.lisp Normal file
View File

@@ -0,0 +1,115 @@
(defpackage :opencortex-memory-tests
(:use :cl :fiveam :opencortex)
(:export #:memory-suite))
(in-package :opencortex-memory-tests)
(def-suite memory-suite
:description "Tests for the Merkle-Tree Memory.")
(in-suite memory-suite)
(test merkle-hash-consistency
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil))
(ast2 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
(clrhash *memory*)
(let ((id1 (ingest-ast ast1)))
(let ((hash1 (org-object-hash (lookup-object id1))))
(clrhash *memory*)
(let ((id2 (ingest-ast ast2)))
(let ((hash2 (org-object-hash (lookup-object id2))))
(is (equal hash1 hash2))))))))
(test merkle-hash-cascading
(let* ((ast-leaf '(:type :HEADLINE :properties (:ID "leaf" :TITLE "Leaf") :contents nil))
(ast-root-full '(:type :HEADLINE :properties (:ID "root" :TITLE "Root")
:contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Leaf") :contents nil))))
(id-root (progn (clrhash *memory*) (ingest-ast ast-root-full)))
(initial-root-hash (org-object-hash (lookup-object id-root))))
;; Now ingest a modified version (title change)
(let* ((ast-root-modified '(:type :HEADLINE :properties (:ID "root" :TITLE "Root")
:contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Leaf Modified") :contents nil))))
(id-root-mod (progn (clrhash *memory*) (ingest-ast ast-root-modified)))
(modified-root-hash (org-object-hash (lookup-object id-root-mod))))
(is (not (equal initial-root-hash modified-root-hash))))))
(test history-store-immutability
"Verify that *history-store* retains old versions even after *memory* updates."
(clrhash *memory*)
(clrhash *history-store*)
(let* ((ast-v1 '(:type :HEADLINE :properties (:ID "test-node" :TITLE "Version 1") :contents nil))
(id-v1 (ingest-ast ast-v1))
(obj-v1 (lookup-object id-v1))
(hash-v1 (org-object-hash obj-v1)))
(let* ((ast-v2 '(:type :HEADLINE :properties (:ID "test-node" :TITLE "Version 2") :contents nil))
(id-v2 (ingest-ast ast-v2))
(obj-v2 (lookup-object id-v2))
(hash-v2 (org-object-hash obj-v2)))
;; The active pointer should be v2
(is (equal (org-object-hash (lookup-object "test-node")) hash-v2))
;; Both v1 and v2 should exist in the immutable history store
(is (not (null (gethash hash-v1 *history-store*))))
(is (not (null (gethash hash-v2 *history-store*))))
;; Modifying v2 should not affect v1 in the history store
(is (equal (org-object-content (gethash hash-v1 *history-store*)) "Version 1
"))
(is (equal (org-object-content (gethash hash-v2 *history-store*)) "Version 2
")))))
(test cow-snapshot-and-rollback
"Verify that lightweight snapshots can accurately restore previous pointer states."
(clrhash *memory*)
(clrhash *history-store*)
(setf *object-store-snapshots* nil)
(let* ((ast-v1 '(:type :HEADLINE :properties (:ID "cow-node" :TITLE "State A") :contents nil))
(id-v1 (ingest-ast ast-v1))
(hash-v1 (org-object-hash (lookup-object id-v1))))
;; Take a snapshot at State A
(snapshot-memory)
(let* ((ast-v2 '(:type :HEADLINE :properties (:ID "cow-node" :TITLE "State B") :contents nil))
(id-v2 (ingest-ast ast-v2))
(hash-v2 (org-object-hash (lookup-object id-v2))))
;; Verify we are currently in State B
(is (equal (org-object-hash (lookup-object "cow-node")) hash-v2))
;; Rollback to State A (index 0 because we only took 1 snapshot)
(rollback-memory 0)
;; Verify we are back in State A
(is (equal (org-object-hash (lookup-object "cow-node")) hash-v1))
;; Verify State B is still safely in the history store (no data loss)
(is (not (null (gethash hash-v2 *history-store*)))))))
(test merkle-hash-consistency
"Verify that identical ASTs produce identical Merkle hashes."
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
(clrhash *memory*)
(let ((id1 (ingest-ast ast1)))
(let ((hash1 (org-object-hash (lookup-object id1))))
(clrhash *memory*)
(let ((id2 (ingest-ast ast1)))
(let ((hash2 (org-object-hash (lookup-object id2))))
(is (equal hash1 hash2))))))))
(test merkle-hash-cascading
"Verify that child changes propagate to parent hashes."
(let* ((ast-root '(:type :HEADLINE :properties (:ID "root" :TITLE "Root")
:contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Leaf") :contents nil))))
(id-root (progn (clrhash *memory*) (ingest-ast ast-root)))
(root-hash (org-object-hash (lookup-object id-root))))
;; Now ingest a modified child - parent hash should change
(let* ((ast-mod '(:type :HEADLINE :properties (:ID "root" :TITLE "Root")
:contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Changed") :contents nil))))
(id-mod (progn (clrhash *memory*) (ingest-ast ast-mod)))
(mod-hash (org-object-hash (lookup-object id-mod))))
(is (not (equal root-hash mod-hash))))))

View File

@@ -0,0 +1,33 @@
(defpackage :opencortex-pipeline-act-tests
(:use :cl :fiveam :opencortex)
(:export #:pipeline-act-suite))
(in-package :opencortex-pipeline-act-tests)
(def-suite pipeline-act-suite
:description "Test suite for Act pipeline")
(in-suite pipeline-act-suite)
(test test-act-gate-symbolic-guard-bypass
"Verify that act-gate proceeds normally when no skill intercepts."
(clrhash opencortex::*skills-registry*)
(let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello"))))
(result (opencortex:act-gate signal)))
(is (eq :acted (getf signal :status)))
(is (null result))))
(test test-act-gate-symbolic-guard-interception
"Verify that act-gate intercepts actions when a skill returns a LOG/EVENT."
(clrhash opencortex::*skills-registry*)
(opencortex::defskill :mock-bouncer
:priority 200
:trigger (lambda (ctx) t)
:deterministic (lambda (action ctx)
(list :type :LOG :payload '(:text "BLOCKED BY SYMBOLIC GUARD"))))
(let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :shell :payload (:cmd "ls"))))
(result (opencortex:act-gate signal)))
(is (eq :acted (getf signal :status)))
(is (not (null result)))
(is (eq :LOG (getf result :type)))
(is (search "BLOCKED BY SYMBOLIC GUARD" (getf (getf result :payload) :text)))))

View File

@@ -0,0 +1,23 @@
(defpackage :opencortex-pipeline-perceive-tests
(:use :cl :fiveam :opencortex)
(:export #:pipeline-perceive-suite))
(in-package :opencortex-pipeline-perceive-tests)
(def-suite pipeline-perceive-suite
:description "Test suite for Perceive pipeline")
(in-suite pipeline-perceive-suite)
(test test-perceive-gate
"Perceive gate should update the object store and normalize signal."
(clrhash opencortex::*memory*)
(let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil))))
(result (perceive-gate signal)))
(is (eq :perceived (getf result :status)))
(is (not (null (gethash "test-node" opencortex::*memory*))))))
(test test-depth-limiting
"Verify that the pipeline terminates runaway feedback loops."
(let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat))))
(is (null (process-signal runaway-signal)))))

View File

@@ -0,0 +1,26 @@
(defpackage :opencortex-pipeline-reason-tests
(:use :cl :fiveam :opencortex)
(:export #:pipeline-reason-suite))
(in-package :opencortex-pipeline-reason-tests)
(def-suite pipeline-reason-suite
:description "Test suite for Reason pipeline")
(in-suite pipeline-reason-suite)
(test test-decide-gate-safety
"Decide gate should block unsafe LLM proposals."
;; Setup: clear skills and register mock
(clrhash opencortex::*skills-registry*)
(opencortex::defskill :mock-safety
:priority 50
:trigger (lambda (ctx) t)
:probabilistic (lambda (ctx) "Mock probabilistic")
:deterministic (lambda (action ctx)
(list :type :LOG :payload (list :text "Action rejected by skill heuristics"))))
(let* ((candidate (list :type :REQUEST :payload (list :action :eval :code "(shell-command \"rm -rf /\")")))
(signal (list :type :EVENT :candidate candidate))
(result (deterministic-verify candidate signal)))
(is (eq :LOG (getf result :type)))
(is (search "Action rejected by skill heuristics" (getf (getf result :payload) :text)))))

View File

@@ -10,25 +10,25 @@
(in-suite self-edit-suite)
(test balance-parens-balanced
(let ((result (opencortex:self-edit-balance-parens "(+ 1 2)")))
(let ((result (opencortex::self-edit-balance-parens "(+ 1 2)")))
(is (string= result "(+ 1 2)"))
(is (not (null (read-from-string result))))))
(test balance-parens-missing-open
(let ((result (opencortex:self-edit-balance-parens "+ 1 2)")))
(let ((result (opencortex::self-edit-balance-parens "+ 1 2)")))
(is (string= result "(+ 1 2)"))
(is (not (null (read-from-string result))))))
(test balance-parens-missing-close
(let ((result (opencortex:self-edit-balance-parens "(+ 1 2")))
(let ((result (opencortex::self-edit-balance-parens "(+ 1 2")))
(is (string= result "(+ 1 2)"))
(is (not (null (read-from-string result))))))
(test balance-parens-deep
(let ((result (opencortex:self-edit-balance-parens "((lambda (x) (if x (+ 1 2) 3))")))
(let ((result (opencortex::self-edit-balance-parens "((lambda (x) (if x (+ 1 2) 3))")))
(is (string= result "((lambda (x) (if x (+ 1 2) 3)))"))
(is (not (null (read-from-string result))))))
(test balance-parens-empty
(let ((result (opencortex:self-edit-balance-parens "")))
(let ((result (opencortex::self-edit-balance-parens "")))
(is (string= result ""))))

View File

@@ -0,0 +1,34 @@
(defpackage :opencortex-tool-permissions-tests
(:use :cl :fiveam :opencortex)
(:export #:tool-permissions-suite))
(in-package :opencortex-tool-permissions-tests)
(def-suite tool-permissions-suite
:description "Tests for Tool Permissions skill")
(in-suite tool-permissions-suite)
(test default-permission-is-allow
"Verify default permission is :allow."
(is (eq (get-tool-permission "unknown-tool") :allow)))
(test set-and-get-permission
"Verify setting and getting permissions."
(set-tool-permission "test-tool-abc" :deny)
(is (eq (get-tool-permission "test-tool-abc") :deny)))
(test permission-gate-allow
"Verify :allow tier passes through."
(set-tool-permission "gate-allow-tool" :allow)
(is (eq (check-tool-permission-gate "gate-allow-tool" nil) :allow)))
(test permission-gate-deny
"Verify :deny tier blocks."
(set-tool-permission "gate-deny-tool" :deny)
(is (eq (check-tool-permission-gate "gate-deny-tool" nil) :deny)))
(test permission-gate-ask
"Verify :ask tier returns ask list."
(set-tool-permission "gate-ask-tool" :ask)
(is (listp (check-tool-permission-gate "gate-ask-tool" nil))))