refactor: Flatten directory structure library->harness, library/gen->skills
This commit is contained in:
313
harness/act.lisp
Normal file
313
harness/act.lisp
Normal file
@@ -0,0 +1,313 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(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 ()
|
||||
"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")))
|
||||
|
||||
;; Parse silent actuators list
|
||||
(when silent
|
||||
(setf *silent-actuators*
|
||||
(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)))
|
||||
(when (and stream (open-stream-p stream))
|
||||
(format stream "~a" (frame-message action))
|
||||
(finish-output stream))))))
|
||||
|
||||
(defun dispatch-action (action context)
|
||||
"Route an approved action to its registered actuator.
|
||||
|
||||
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))
|
||||
|
||||
(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)
|
||||
"Execute internal harness commands.
|
||||
|
||||
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)
|
||||
"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))
|
||||
(depth (getf context :depth 0))
|
||||
(meta (getf context :meta))
|
||||
(source (getf meta :source))
|
||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
||||
|
||||
(if tool
|
||||
(handler-case
|
||||
;; 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)))
|
||||
|
||||
;; 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)))))
|
||||
|
||||
;; 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 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 signal))
|
||||
|
||||
;; 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)))
|
||||
|
||||
;; 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)))))
|
||||
|
||||
;; Step 2: Actuation based on signal type
|
||||
(case type
|
||||
;; 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)))
|
||||
|
||||
;; 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))
|
||||
@@ -35,7 +35,7 @@ Example feedback chain:
|
||||
|
||||
* Package Context
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
#+begin_src lisp :tangle ./act.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
@@ -43,7 +43,7 @@ Example feedback chain:
|
||||
|
||||
** Actuator Registry Variables
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
#+begin_src lisp :tangle ./act.lisp
|
||||
(defvar *default-actuator* :cli
|
||||
"The actuator used when no explicit target is specified.
|
||||
Override with DEFAULT_ACTUATOR environment variable.")
|
||||
@@ -55,7 +55,7 @@ Example feedback chain:
|
||||
|
||||
** initialize-actuators: System Bootstrap
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
#+begin_src lisp :tangle ./act.lisp
|
||||
(defun initialize-actuators ()
|
||||
"Load actuator configuration from environment and register core actuators.
|
||||
|
||||
@@ -102,7 +102,7 @@ Example feedback chain:
|
||||
|
||||
** dispatch-action: The Router
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
#+begin_src lisp :tangle ./act.lisp
|
||||
(defun dispatch-action (action context)
|
||||
"Route an approved action to its registered actuator.
|
||||
|
||||
@@ -149,7 +149,7 @@ Example feedback chain:
|
||||
|
||||
** execute-system-action: Internal Commands
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
#+begin_src lisp :tangle ./act.lisp
|
||||
(defun execute-system-action (action context)
|
||||
"Execute internal harness commands.
|
||||
|
||||
@@ -198,7 +198,7 @@ Example feedback chain:
|
||||
|
||||
** execute-tool-action: Cognitive Tool Execution
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
#+begin_src lisp :tangle ./act.lisp
|
||||
(defun execute-tool-action (action context)
|
||||
"Execute a registered cognitive tool.
|
||||
|
||||
@@ -267,7 +267,7 @@ Example feedback chain:
|
||||
|
||||
** format-tool-result: Human-Readable Output
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
#+begin_src lisp :tangle ./act.lisp
|
||||
(defun format-tool-result (tool-name result)
|
||||
"Format a tool result for human-readable display.
|
||||
|
||||
@@ -295,7 +295,7 @@ Example feedback chain:
|
||||
|
||||
** act-gate: Final Pipeline Stage
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
#+begin_src lisp :tangle ./act.lisp
|
||||
(defun act-gate (signal)
|
||||
"Final stage of the metabolic pipeline: Actuation.
|
||||
|
||||
@@ -392,7 +392,7 @@ Example feedback chain:
|
||||
These tests verify the Act pipeline. Run with:
|
||||
~(fiveam:run! 'pipeline-act-suite)~
|
||||
|
||||
#+begin_src lisp :tangle ../tests/pipeline-act-tests.lisp
|
||||
#+begin_src lisp :tangle ./tests/pipeline-act-tests.lisp
|
||||
(defpackage :opencortex-pipeline-act-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:pipeline-act-suite))
|
||||
|
||||
41
harness/communication-tests.lisp
Normal file
41
harness/communication-tests.lisp
Normal file
@@ -0,0 +1,41 @@
|
||||
(defpackage :opencortex-communication-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:communication-protocol-suite))
|
||||
|
||||
(in-package :opencortex-communication-tests)
|
||||
|
||||
(def-suite communication-protocol-suite
|
||||
:description "Test suite for opencortex Communication Protocol")
|
||||
|
||||
(in-suite communication-protocol-suite)
|
||||
|
||||
(test test-framing
|
||||
"Verify that messages are correctly prefixed with a 6-character hex length."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake)))
|
||||
(framed (frame-message msg))
|
||||
(len-str (subseq framed 0 6))
|
||||
(payload (subseq framed 6)))
|
||||
(is (string= "00002C" (string-upcase len-str)))
|
||||
(is (equalp msg (read-from-string payload)))))
|
||||
|
||||
(test test-parse-message
|
||||
"Verify that incoming framed strings are parsed into Lisp plists."
|
||||
(let ((framed "00002c(:type :EVENT :payload (:action :handshake))"))
|
||||
(is (equal '(:type :EVENT :payload (:action :handshake))
|
||||
(read-from-string (subseq framed 6))))))
|
||||
|
||||
(test test-hello-handshake
|
||||
"Verify the structure of the HELLO handshake message."
|
||||
(let ((hello (make-hello-message "0.1.0")))
|
||||
(is (eq :EVENT (getf hello :type)))
|
||||
(is (eq :handshake (getf (getf hello :payload) :action)))
|
||||
(is (string= "0.1.0" (getf (getf hello :payload) :version)))))
|
||||
|
||||
(test test-find-missing-id
|
||||
"Verify that the daemon can find a headline missing an ID."
|
||||
(let* ((ast '(:type :org-data :contents
|
||||
((:type :HEADLINE :properties (:TITLE "No ID Here") :contents nil)
|
||||
(:type :HEADLINE :properties (:ID "exists" :TITLE "Has ID") :contents nil))))
|
||||
(found (find-headline-missing-id ast)))
|
||||
(is (not (null found)))
|
||||
(is (string= "No ID Here" (getf (getf found :properties) :TITLE)))))
|
||||
44
harness/communication-validator.lisp
Normal file
44
harness/communication-validator.lisp
Normal file
@@ -0,0 +1,44 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Strict structural validation for incoming communication protocol messages."
|
||||
(unless (listp msg)
|
||||
(error "Communication Protocol Schema Error: Message must be a property list (got ~s)" (type-of msg)))
|
||||
|
||||
(let ((type (let ((raw (proto-get msg :type))) (if (keywordp raw) (intern (string-upcase (string raw)) :keyword) raw))))
|
||||
(unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS))
|
||||
(progn (harness-log "REJECTED MSG: ~s" msg) (error "Communication Protocol Schema Error: Invalid message type '~a'" type)))
|
||||
|
||||
(case type
|
||||
(:REQUEST
|
||||
;; Allow missing :target if :source is present in :meta, since reason-gate
|
||||
;; will infer :target from :source downstream. This preserves "equality of
|
||||
;; clients" — gateways need not duplicate routing logic.
|
||||
(let ((target (proto-get msg :target))
|
||||
(source (proto-get (proto-get msg :meta) :source)))
|
||||
(unless (or target source)
|
||||
(error "Communication Protocol Schema Error: REQUEST missing mandatory :target and no :source in :meta to infer it"))
|
||||
(unless (proto-get msg :payload)
|
||||
(error "Communication Protocol Schema Error: REQUEST missing mandatory :payload"))))
|
||||
|
||||
(:EVENT
|
||||
(let ((payload (proto-get msg :payload)))
|
||||
(unless (and payload (listp payload))
|
||||
(error "Communication Protocol Schema Error: EVENT missing or invalid :payload"))
|
||||
(unless (or (proto-get payload :action) (proto-get payload :sensor))
|
||||
(error "Communication Protocol Schema Error: EVENT payload must contain :action or :sensor"))))
|
||||
|
||||
(:RESPONSE
|
||||
(unless (proto-get msg :payload)
|
||||
(error "Communication Protocol Schema Error: RESPONSE missing mandatory :payload"))))
|
||||
|
||||
t))
|
||||
|
||||
(defskill :skill-communication-protocol-validator
|
||||
:priority 95
|
||||
:trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:protocol-received)))
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(validate-communication-protocol-schema action)
|
||||
action))
|
||||
78
harness/communication.lisp
Normal file
78
harness/communication.lisp
Normal file
@@ -0,0 +1,78 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
"Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
||||
"Global registry mapping target keywords to their physical actuator functions.")
|
||||
|
||||
(defun register-actuator (name fn)
|
||||
"Registers an actuator function. Actuators receive: (ACTION CONTEXT)."
|
||||
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
||||
(setf (gethash key *actuator-registry*) fn)))
|
||||
|
||||
;; Removed duplicate frame-message - kept the sanitized version below
|
||||
|
||||
(defun read-framed-message (stream)
|
||||
"Reads a hex-length prefixed S-expression from the stream securely. Skips leading whitespace."
|
||||
(let ((length-buffer (make-string 6)))
|
||||
(handler-case
|
||||
(progn
|
||||
;; 1. Skip leading whitespace (newlines, spaces, etc.)
|
||||
(loop for char = (peek-char nil stream nil :eof)
|
||||
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return)))
|
||||
do (read-char stream))
|
||||
|
||||
;; 2. Read the 6-char hex length
|
||||
(let ((count (read-sequence length-buffer stream)))
|
||||
(cond ((< count 6) :eof)
|
||||
(t (let ((len (ignore-errors (parse-integer length-buffer :radix 16))))
|
||||
(if (not len)
|
||||
(progn
|
||||
(harness-log "PROTOCOL ERROR: Invalid header ~s. Attempting resync..." length-buffer)
|
||||
:error)
|
||||
(let ((msg-buffer (make-string len)))
|
||||
(read-sequence msg-buffer stream)
|
||||
(let ((*read-eval* nil)
|
||||
(*print-pretty* nil))
|
||||
(handler-case
|
||||
(let ((msg (read-from-string msg-buffer)))
|
||||
(validate-communication-protocol-schema msg)
|
||||
msg)
|
||||
(error (c)
|
||||
(harness-log "PROTOCOL PARSE ERROR: ~a in ~s" c msg-buffer)
|
||||
:error))))))))))
|
||||
(error (c)
|
||||
(harness-log "PROTOCOL READ ERROR: ~a" c)
|
||||
:error))))
|
||||
|
||||
(defun make-hello-message (version)
|
||||
"Constructs the standard HELLO handshake message."
|
||||
(list :TYPE :EVENT
|
||||
:PAYLOAD (list :ACTION :handshake
|
||||
:VERSION version
|
||||
:CAPABILITIES '(:AUTH :SWANK :ORG-AST))))
|
||||
|
||||
(defun sanitize-protocol-message (msg)
|
||||
"Recursively strips non-serializable objects from a protocol plist."
|
||||
(if (and msg (listp msg))
|
||||
(let ((clean nil))
|
||||
(loop for (k v) on msg by #'cddr
|
||||
do (unless (member k '(:reply-stream :socket :stream))
|
||||
(push k clean)
|
||||
(push (if (listp v) (sanitize-protocol-message v) v) clean)))
|
||||
(nreverse clean))
|
||||
msg))
|
||||
|
||||
(defun frame-message (msg)
|
||||
"Serializes a message plist and prefixes it with a 6-character hex length."
|
||||
(let* ((sanitized (sanitize-protocol-message msg))
|
||||
(payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized)))
|
||||
(len (length payload)))
|
||||
(format nil "~6,'0x~a" len payload)))
|
||||
@@ -10,7 +10,7 @@ The ~communication.lisp~ module defines the low-level transport and framing logi
|
||||
|
||||
* Implementation (communication.lisp)
|
||||
|
||||
#+begin_src lisp :tangle ../library/communication.lisp
|
||||
#+begin_src lisp :tangle ./communication.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
@@ -21,7 +21,7 @@ The ~communication.lisp~ module defines the low-level transport and framing logi
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp :tangle ../library/communication.lisp
|
||||
#+begin_src lisp :tangle ./communication.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
||||
@@ -78,7 +78,7 @@ The ~communication.lisp~ module defines the low-level transport and framing logi
|
||||
** Structural Validation (communication-validator.lisp)
|
||||
The validator ensures that incoming messages adhere to the strict property list schema of the communication protocol.
|
||||
|
||||
#+begin_src lisp :tangle ../library/communication-validator.lisp
|
||||
#+begin_src lisp :tangle ./communication-validator.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
@@ -128,7 +128,7 @@ The validator ensures that incoming messages adhere to the strict property list
|
||||
** Message Framing (communication.lisp)
|
||||
Frames a message with a hex length prefix and ensures all data is serializable.
|
||||
|
||||
#+begin_src lisp :tangle ../library/communication.lisp
|
||||
#+begin_src lisp :tangle ./communication.lisp
|
||||
(defun sanitize-protocol-message (msg)
|
||||
"Recursively strips non-serializable objects from a protocol plist."
|
||||
(if (and msg (listp msg))
|
||||
@@ -153,7 +153,7 @@ Frames a message with a hex length prefix and ensures all data is serializable.
|
||||
These tests verify the communication protocol functions. Run with:
|
||||
~(fiveam:run! 'communication-protocol-suite)~
|
||||
|
||||
#+begin_src lisp :tangle ../library/communication-tests.lisp
|
||||
#+begin_src lisp :tangle ./communication-tests.lisp
|
||||
(defpackage :opencortex-communication-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:communication-protocol-suite))
|
||||
|
||||
119
harness/context.lisp
Normal file
119
harness/context.lisp
Normal file
@@ -0,0 +1,119 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun context-query-store (&key tag todo-state type)
|
||||
"Filters the Memory based on tags, todo states, or types."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let* ((attrs (org-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t))
|
||||
(when (and type (not (eq (org-object-type obj) type))) (setf match nil))
|
||||
(when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil)))
|
||||
(when (and todo-state (not (equal state todo-state))) (setf match nil))
|
||||
(when match (push obj results))))
|
||||
*memory*)
|
||||
results))
|
||||
|
||||
(defun context-get-active-projects ()
|
||||
"Returns headlines tagged as 'project' that are not yet marked DONE."
|
||||
(remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(context-query-store :tag "project" :type :HEADLINE)))
|
||||
|
||||
(defun context-get-recent-completed-tasks ()
|
||||
"Retrieves recently finished tasks from the store."
|
||||
(context-query-store :todo-state "DONE" :type :HEADLINE))
|
||||
|
||||
(defun context-list-all-skills ()
|
||||
"Provides a sorted overview of currently loaded system capabilities."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results))
|
||||
*skills-registry*)
|
||||
(sort results #'> :key (lambda (x) (getf x :priority)))))
|
||||
|
||||
(defun context-get-skill-source (skill-name)
|
||||
"Reads the raw literate source of a specific skill for inspection."
|
||||
(let* ((filename (format nil "~a.org" skill-name))
|
||||
(skills-dir-str (or (uiop:getenv "SKILLS_DIR") (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))
|
||||
(skills-dir (uiop:ensure-directory-pathname (context-resolve-path skills-dir-str)))
|
||||
(full-path (merge-pathnames filename skills-dir)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
|
||||
(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)))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(let ((count (min log-limit (length *system-logs*))))
|
||||
(subseq *system-logs* 0 count)))))
|
||||
|
||||
(defun context-render-to-org (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil))
|
||||
"Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model."
|
||||
(let* ((id (org-object-id obj))
|
||||
(is-foveal (equal id foveal-id))
|
||||
(title (or (getf (org-object-attributes obj) :TITLE) "Untitled"))
|
||||
(content (org-object-content obj))
|
||||
(children (org-object-children obj))
|
||||
(stars (make-string depth :initial-element #\*))
|
||||
(obj-vector (org-object-vector obj))
|
||||
(threshold (or semantic-threshold (ignore-errors (read-from-string (uiop:getenv "CONTEXT_SEMANTIC_THRESHOLD"))) 0.75))
|
||||
(similarity (if (and foveal-vector obj-vector (not is-foveal))
|
||||
(cosine-similarity foveal-vector obj-vector)
|
||||
0.0))
|
||||
(is-semantically-relevant (>= similarity threshold))
|
||||
;; We always render depth 1 and 2 (Projects and main tasks).
|
||||
;; We always render the foveal node and its immediate children.
|
||||
;; We render deeper nodes ONLY if they are semantically relevant.
|
||||
(should-render (or (<= depth 2) is-foveal is-semantically-relevant))
|
||||
(output ""))
|
||||
|
||||
(when should-render
|
||||
(setf output (format nil "~a ~a~%:PROPERTIES:~%:ID: ~a~%" stars title id))
|
||||
(when is-semantically-relevant
|
||||
(setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity))))
|
||||
(setf output (concatenate 'string output (format nil ":END:~%")))
|
||||
|
||||
;; Only include full body content if this is the Foveal focus or highly relevant
|
||||
(when (and content (or is-foveal is-semantically-relevant))
|
||||
(setf output (concatenate 'string output content (string #\Newline))))
|
||||
|
||||
;; Recursively render children
|
||||
(dolist (child-id children)
|
||||
(let ((child-obj (lookup-object child-id)))
|
||||
(when child-obj
|
||||
;; If the current node is Foveal, its children should be rendered (depth effectively resets)
|
||||
(let ((next-foveal (if is-foveal child-id foveal-id)))
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org child-obj
|
||||
:depth (1+ depth)
|
||||
:foveal-id next-foveal
|
||||
:semantic-threshold threshold
|
||||
:foveal-vector foveal-vector))))))))
|
||||
output))
|
||||
|
||||
(defun context-resolve-path (path-string)
|
||||
"Expands environment variables and strips literal quotes from a path string."
|
||||
(let ((path (if (stringp path-string)
|
||||
(string-trim '(#\" #\' #\Space) path-string)
|
||||
path-string)))
|
||||
(if (and (stringp path) (search "$" path))
|
||||
(let ((result path))
|
||||
(ppcre:do-register-groups (var-name) ("\\$([A-Za-z0-9_]+)" path)
|
||||
(let ((var-val (uiop:getenv var-name)))
|
||||
(when var-val
|
||||
(setf result (ppcre:regex-replace (format nil "\\$~a" var-name) result var-val)))))
|
||||
result)
|
||||
path)))
|
||||
|
||||
(defun context-assemble-global-awareness (&optional signal)
|
||||
"Produces a high-level skeletal outline of the current Memory for the LLM."
|
||||
(let* ((foveal-id (or (getf signal :foveal-focus)
|
||||
(ignore-errors (getf (getf signal :payload) :target-id))))
|
||||
(projects (context-get-active-projects))
|
||||
(output "GLOBAL MEMEX AWARENESS (Peripheral Vision):
|
||||
"))
|
||||
(if projects
|
||||
(dolist (project projects)
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org project :foveal-id foveal-id))))
|
||||
(setf output (concatenate 'string output "No active projects found.~%")))
|
||||
output))
|
||||
@@ -37,14 +37,14 @@ The ~context.lisp~ module provides the deterministic functional layer for queryi
|
||||
** Package Context
|
||||
We begin by ensuring we are executing within the correct isolated package namespace.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
#+begin_src lisp :tangle ./context.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Querying the Store (context-query-store)
|
||||
A generalized filter for the Memory. This function allows skills to perform high-level semantic sweeps of the Memex based on tags, TODO states, or Org element types. It returns a list of ~org-object~ structures.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
#+begin_src lisp :tangle ./context.lisp
|
||||
(defun context-query-store (&key tag todo-state type)
|
||||
"Filters the Memory based on tags, todo states, or types."
|
||||
(let ((results nil))
|
||||
@@ -62,7 +62,7 @@ A generalized filter for the Memory. This function allows skills to perform high
|
||||
** Active Projects (context-get-active-projects)
|
||||
Identifies headlines tagged with ~project~ that have not yet reached a terminal ~DONE~ state. This provides the primary high-level structure for the agent's global awareness.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
#+begin_src lisp :tangle ./context.lisp
|
||||
(defun context-get-active-projects ()
|
||||
"Returns headlines tagged as 'project' that are not yet marked DONE."
|
||||
(remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
@@ -72,7 +72,7 @@ Identifies headlines tagged with ~project~ that have not yet reached a terminal
|
||||
** Completed Tasks (context-get-recent-completed-tasks)
|
||||
Retrieves a list of tasks that have reached the terminal ~DONE~ state. This is useful for providing the agent with historical context or for generating summaries of recent work.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
#+begin_src lisp :tangle ./context.lisp
|
||||
(defun context-get-recent-completed-tasks ()
|
||||
"Retrieves recently finished tasks from the store."
|
||||
(context-query-store :todo-state "DONE" :type :HEADLINE))
|
||||
@@ -81,7 +81,7 @@ Retrieves a list of tasks that have reached the terminal ~DONE~ state. This is u
|
||||
** Capability Discovery (context-list-all-skills)
|
||||
Provides a sorted list of all currently loaded skills. In a "Self-Writing" environment, the agent must be able to discover and understand its own capabilities. This function provides the metadata necessary for the agent to decide which skill to trigger or how to resolve dependencies.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
#+begin_src lisp :tangle ./context.lisp
|
||||
(defun context-list-all-skills ()
|
||||
"Provides a sorted overview of currently loaded system capabilities."
|
||||
(let ((results nil))
|
||||
@@ -95,7 +95,7 @@ Provides a sorted list of all currently loaded skills. In a "Self-Writing" envir
|
||||
** Skill Inspection (context-get-skill-source)
|
||||
Reads the raw literate Org source of a specific skill. This is a foundational capability for an agent expected to eventually "self-write" or perform its own maintenance. By reading the literate source, the agent can understand the *intent* behind a skill's logic before proposing a modification. We use the `SKILLS_DIR` environment variable to locate the source files.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
#+begin_src lisp :tangle ./context.lisp
|
||||
(defun context-get-skill-source (skill-name)
|
||||
"Reads the raw literate source of a specific skill for inspection."
|
||||
(let* ((filename (format nil "~a.org" skill-name))
|
||||
@@ -108,7 +108,7 @@ Reads the raw literate Org source of a specific skill. This is a foundational ca
|
||||
** Harness Logs (context-get-system-logs)
|
||||
Retrieves the most recent entries from the harness's internal circular log buffer. This allows the Probabilistic Engine to see recent errors or successful dispatches, enabling it to course-correct or explain failures to the user. The log limit is externalized to `CONTEXT_LOG_LIMIT`.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
#+begin_src lisp :tangle ./context.lisp
|
||||
(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)))
|
||||
@@ -128,7 +128,7 @@ It implements the following deterministic logic:
|
||||
|
||||
The semantic threshold is externalized to `CONTEXT_SEMANTIC_THRESHOLD`.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
#+begin_src lisp :tangle ./context.lisp
|
||||
(defun context-render-to-org (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil))
|
||||
"Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model."
|
||||
(let* ((id (org-object-id obj))
|
||||
@@ -177,7 +177,7 @@ The semantic threshold is externalized to `CONTEXT_SEMANTIC_THRESHOLD`.
|
||||
** Path Resolution (context-resolve-path)
|
||||
A utility function that expands environment variables (like ~$HOME~ or ~$MEMEX_ROOT~) within path strings. This ensures that the agent can interact with files across different machine configurations without hardcoding absolute paths. This version is more robust, supporting multiple environment variables throughout the string.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
#+begin_src lisp :tangle ./context.lisp
|
||||
(defun context-resolve-path (path-string)
|
||||
"Expands environment variables and strips literal quotes from a path string."
|
||||
(let ((path (if (stringp path-string)
|
||||
@@ -196,7 +196,7 @@ A utility function that expands environment variables (like ~$HOME~ or ~$MEMEX_R
|
||||
** Global Awareness (context-assemble-global-awareness)
|
||||
The primary entry point for context generation. This function identifies active projects and the current user focus (captured during the Perceive stage), then invokes the recursive renderer to assemble the pruned Org-mode skeletal outline sent to the LLM.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
#+begin_src lisp :tangle ./context.lisp
|
||||
(defun context-assemble-global-awareness (&optional signal)
|
||||
"Produces a high-level skeletal outline of the current Memory for the LLM."
|
||||
(let* ((foveal-id (or (getf signal :foveal-focus)
|
||||
@@ -216,7 +216,7 @@ The primary entry point for context generation. This function identifies active
|
||||
Following the Engineering Standards, the peripheral vision extraction and rendering logic must be empirically verified.
|
||||
|
||||
** Test Suite Context
|
||||
#+begin_src lisp :tangle ../tests/peripheral-vision-tests.lisp
|
||||
#+begin_src lisp :tangle ./tests/peripheral-vision-tests.lisp
|
||||
(defpackage :opencortex-peripheral-vision-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:vision-suite))
|
||||
@@ -230,7 +230,7 @@ Following the Engineering Standards, the peripheral vision extraction and render
|
||||
** Foveal Rendering Test
|
||||
Verify that the foveal target is rendered with content, while siblings are skeletal.
|
||||
|
||||
#+begin_src lisp :tangle ../tests/peripheral-vision-tests.lisp
|
||||
#+begin_src lisp :tangle ./tests/peripheral-vision-tests.lisp
|
||||
(test test-foveal-rendering
|
||||
"Verify that the foveal target is rendered with content, while siblings are skeletal."
|
||||
(clrhash opencortex::*memory*)
|
||||
@@ -250,7 +250,7 @@ Verify that the foveal target is rendered with content, while siblings are skele
|
||||
** Awareness Budget Test
|
||||
Verify that context-assemble-global-awareness handles multiple projects correctly.
|
||||
|
||||
#+begin_src lisp :tangle ../tests/peripheral-vision-tests.lisp
|
||||
#+begin_src lisp :tangle ./tests/peripheral-vision-tests.lisp
|
||||
(test test-awareness-budget
|
||||
"Verify that context-assemble-global-awareness handles multiple projects."
|
||||
(clrhash opencortex::*memory*)
|
||||
|
||||
193
harness/loop.lisp
Normal file
193
harness/loop.lisp
Normal file
@@ -0,0 +1,193 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(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.
|
||||
|
||||
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 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)))
|
||||
(if feedback
|
||||
;; Action generated a feedback signal - continue processing
|
||||
(progn
|
||||
;; 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 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)
|
||||
;; 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
|
||||
"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
|
||||
"Tracks heartbeats since last save, used to calculate auto-save timing.")
|
||||
|
||||
(defun start-heartbeat ()
|
||||
"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*
|
||||
(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 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
|
||||
"When T, save memory to disk on graceful shutdown.
|
||||
Disable for testing or when memory persistence is handled externally.")
|
||||
|
||||
(defun main ()
|
||||
"Entry point for OpenCortex. Initializes the system and enters idle loop.
|
||||
|
||||
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)
|
||||
|
||||
;; 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))
|
||||
(harness-log "SHUTDOWN: SIGINT received. Saving memory...")
|
||||
(when *shutdown-save-enabled*
|
||||
(save-memory-to-disk))
|
||||
(uiop:quit 0)))
|
||||
|
||||
;; 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))
|
||||
(return))
|
||||
|
||||
;; Sleep in configured intervals (default: 1 hour)
|
||||
(sleep sleep-interval))))
|
||||
@@ -35,7 +35,7 @@ The loop operates in a multi-threaded environment:
|
||||
|
||||
* Package and Thread-Safe Variables
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
#+begin_src lisp :tangle ./loop.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *interrupt-flag* nil
|
||||
@@ -58,7 +58,7 @@ This function implements the Perceive-Reason-Act pipeline. It processes a signal
|
||||
|
||||
The depth counter prevents infinite recursion—a signal that generates another signal that generates another, etc. By limiting to depth 10, we ensure the system eventually converges or gracefully terminates.
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
#+begin_src lisp :tangle ./loop.lisp
|
||||
(defun process-signal (signal)
|
||||
"The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act.
|
||||
|
||||
@@ -152,7 +152,7 @@ The heartbeat thread ensures the agent remains alive even without external input
|
||||
|
||||
** Heartbeat Configuration Variables
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
#+begin_src lisp :tangle ./loop.lisp
|
||||
(defvar *auto-save-interval* 300
|
||||
"Interval in seconds between automatic memory saves.
|
||||
Defaults to 300 seconds (5 minutes). Set via MEMORY_AUTO_SAVE_INTERVAL env var.")
|
||||
@@ -163,7 +163,7 @@ The heartbeat thread ensures the agent remains alive even without external input
|
||||
|
||||
** start-heartbeat: The Pulsing Heart
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
#+begin_src lisp :tangle ./loop.lisp
|
||||
(defun start-heartbeat ()
|
||||
"Starts the background heartbeat thread.
|
||||
|
||||
@@ -209,7 +209,7 @@ The heartbeat thread ensures the agent remains alive even without external input
|
||||
|
||||
** Shutdown Configuration
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
#+begin_src lisp :tangle ./loop.lisp
|
||||
(defvar *shutdown-save-enabled* t
|
||||
"When T, save memory to disk on graceful shutdown.
|
||||
Disable for testing or when memory persistence is handled externally.")
|
||||
@@ -226,7 +226,7 @@ The main function orchestrates system startup:
|
||||
5. Register SIGINT handler for graceful Ctrl+C shutdown
|
||||
6. Enter idle loop (sleeping in 1-hour increments)
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
#+begin_src lisp :tangle ./loop.lisp
|
||||
(defun main ()
|
||||
"Entry point for OpenCortex. Initializes the system and enters idle loop.
|
||||
|
||||
@@ -291,7 +291,7 @@ The main function orchestrates system startup:
|
||||
These tests verify the metabolic loop and error recovery. Run with:
|
||||
~(fiveam:run! 'immune-suite)~
|
||||
|
||||
#+begin_src lisp :tangle ../tests/immune-system-tests.lisp
|
||||
#+begin_src lisp :tangle ./tests/immune-system-tests.lisp
|
||||
(defpackage :opencortex-immune-system-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:immune-suite))
|
||||
|
||||
119
harness/memory.lisp
Normal file
119
harness/memory.lisp
Normal file
@@ -0,0 +1,119 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *memory* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *history-store* (make-hash-table :test 'equal)
|
||||
"Immutable Merkle-Tree versioning store mapping hashes to objects.")
|
||||
|
||||
(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)))
|
||||
(sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x)))))
|
||||
(attr-string (format nil "~s" sorted-alist))
|
||||
(children-string (format nil "~{~a~}" child-hashes))
|
||||
(data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a"
|
||||
id type attr-string (or content "") children-string))
|
||||
(digester (ironclad:make-digest :sha256)))
|
||||
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string))
|
||||
(ironclad:byte-array-to-hex-string (ironclad:produce-digest digester))))
|
||||
|
||||
(defun ingest-ast (ast &optional parent-id)
|
||||
"Parses an Org AST into the recursive Lisp Memory with Merkle hashing."
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (or (getf props :ID) (format nil "temp-~a" (get-universal-time))))
|
||||
(contents (getf ast :contents))
|
||||
(raw-content (when (eq type :HEADLINE)
|
||||
(format nil "~a~%~a" (getf props :TITLE) (or (cl:getf ast :raw-content) ""))))
|
||||
(should-embed (and raw-content (equal (getf props :EMBED) "t")))
|
||||
(child-ids nil)
|
||||
(child-hashes nil))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(let ((child-id (ingest-ast child id)))
|
||||
(push child-id child-ids)
|
||||
(let ((child-id-val child-id))
|
||||
(let ((child-obj (lookup-object child-id-val)))
|
||||
(when child-obj (push (org-object-hash child-obj) child-hashes)))))))
|
||||
(setf child-ids (nreverse child-ids))
|
||||
(setf child-hashes (nreverse child-hashes))
|
||||
(let* ((hash (compute-merkle-hash id type props raw-content child-hashes))
|
||||
(existing-obj (gethash hash *history-store*))
|
||||
(obj (or existing-obj
|
||||
(make-org-object
|
||||
:id id :type type :attributes props :content raw-content
|
||||
:vector (when should-embed (get-embedding raw-content))
|
||||
:parent-id parent-id :children child-ids
|
||||
:version (get-universal-time) :last-sync (get-universal-time)
|
||||
:hash hash))))
|
||||
(unless existing-obj
|
||||
(setf (gethash hash *history-store*) obj))
|
||||
(setf (gethash id *memory*) obj)
|
||||
id)))
|
||||
|
||||
(defvar *object-store-snapshots* nil)
|
||||
|
||||
(defun copy-hash-table (hash-table)
|
||||
"Creates a shallow copy of a hash table."
|
||||
(let ((new-table (make-hash-table :test (hash-table-test hash-table)
|
||||
:size (hash-table-size hash-table))))
|
||||
(maphash (lambda (k v) (setf (gethash k new-table) v)) hash-table)
|
||||
new-table))
|
||||
|
||||
(defun snapshot-memory ()
|
||||
"Creates a lightweight, Copy-on-Write snapshot using Merkle-Tree pointers."
|
||||
(let ((snapshot (copy-hash-table *memory*)))
|
||||
(push (list :timestamp (get-universal-time) :data snapshot) *object-store-snapshots*)
|
||||
(when (> (length *object-store-snapshots*) 20)
|
||||
(setf *object-store-snapshots* (subseq *object-store-snapshots* 0 20)))
|
||||
(harness-log "MEMORY - CoW Memory snapshot created.")))
|
||||
|
||||
(defun rollback-memory (&optional (index 0))
|
||||
"Restores the Memory to a previously captured snapshot using immutable history pointers."
|
||||
(let ((snapshot (nth index *object-store-snapshots*)))
|
||||
(if snapshot
|
||||
(progn (setf *memory* (copy-hash-table (getf snapshot :data)))
|
||||
(harness-log "MEMORY - Memory rolled back to snapshot ~a" index))
|
||||
(harness-log "MEMORY ERROR - Snapshot ~a not found." index))))
|
||||
|
||||
(defun org-id-new ()
|
||||
"Generates a new UUID string for Org-mode identification."
|
||||
(string-downcase (format nil "~a" (uuid:make-v4-uuid))))
|
||||
|
||||
(defun lookup-object (id)
|
||||
"Retrieves an object from the store by its unique ID."
|
||||
(gethash id *memory*))
|
||||
|
||||
(defun list-objects-by-type (type)
|
||||
"Returns a list of all objects matching a specific Org element type."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj) (declare (ignore id)) (when (eq (org-object-type obj) type) (push obj results))) *memory*)
|
||||
results))
|
||||
(defun list-objects-with-attribute (attr-name value)
|
||||
"Returns a list of all objects where ATTR-NAME matches VALUE."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let ((attrs (org-object-attributes obj)))
|
||||
(when (equal (getf attrs attr-name) value)
|
||||
(push obj results))))
|
||||
*memory*)
|
||||
results))
|
||||
|
||||
(defun find-headline-missing-id (ast)
|
||||
"Traverses an AST to find headlines that lack an :ID: property."
|
||||
(when (listp ast)
|
||||
(if (and (eq (getf ast :type) :HEADLINE) (not (getf (getf ast :properties) :ID)))
|
||||
ast
|
||||
(cl:some #'find-headline-missing-id (getf ast :contents)))))
|
||||
|
||||
(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)))
|
||||
@@ -31,14 +31,14 @@ flowchart TD
|
||||
#+end_src
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** The Object Repository
|
||||
The `*memory*` is the global hash table that holds every Org element by its unique ID. This is the "live RAM" of the agent's memory.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(defvar *memory* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *history-store* (make-hash-table :test 'equal)
|
||||
@@ -48,7 +48,7 @@ The `*memory*` is the global hash table that holds every Org element by its uniq
|
||||
** The Data Structure (org-object)
|
||||
Every element in the Memex (headlines, paragraphs, etc.) is represented by an `org-object` structure. It contains both semantic metadata (attributes, content) and structural metadata (parent/child pointers, Merkle hashes).
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(defstruct org-object
|
||||
id type attributes content vector parent-id children version last-sync hash)
|
||||
|
||||
@@ -60,7 +60,7 @@ Every element in the Memex (headlines, paragraphs, etc.) is represented by an `o
|
||||
** Merkle Tree Integrity (compute-merkle-hash)
|
||||
The `compute-merkle-hash` function ensures the cryptographic integrity of the knowledge graph. A node's hash depends on its own properties and the hashes of all its children. This creates a recursive fingerprint where any change to a single note propagates up to the root hash.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(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)))
|
||||
@@ -77,7 +77,7 @@ The `compute-merkle-hash` function ensures the cryptographic integrity of the kn
|
||||
** Ingesting the AST (ingest-ast)
|
||||
The `ingest-ast` function is the primary bridge between the external world (Emacs/JSON) and the internal Lisp machine. It recursively parses an Org-mode Abstract Syntax Tree (AST) into `org-object` structures and registers them in the store.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(defun ingest-ast (ast &optional parent-id)
|
||||
"Parses an Org AST into the recursive Lisp Memory with Merkle hashing."
|
||||
(let* ((type (getf ast :type))
|
||||
@@ -116,7 +116,7 @@ The `ingest-ast` function is the primary bridge between the external world (Emac
|
||||
** Memory Snapshots (snapshot-memory)
|
||||
Because objects are stored immutably in the `*history-store*`, a snapshot is a lightweight shallow copy of the active `*memory*` pointers. The system maintains a rolling buffer of 20 snapshots, allowing for near-instant, zero-cost rollback.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(defvar *object-store-snapshots* nil)
|
||||
|
||||
(defun copy-hash-table (hash-table)
|
||||
@@ -138,7 +138,7 @@ Because objects are stored immutably in the `*history-store*`, a snapshot is a l
|
||||
** Memory Rollback (rollback-memory)
|
||||
Restores the state of the Memex from one of the previous snapshots.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(defun rollback-memory (&optional (index 0))
|
||||
"Restores the Memory to a previously captured snapshot using immutable history pointers."
|
||||
(let ((snapshot (nth index *object-store-snapshots*)))
|
||||
@@ -153,7 +153,7 @@ Restores the state of the Memex from one of the previous snapshots.
|
||||
These tests verify the Memory system. Run with:
|
||||
~(fiveam:run! 'memory-suite)~
|
||||
|
||||
#+begin_src lisp :tangle ../tests/memory-tests.lisp
|
||||
#+begin_src lisp :tangle ./tests/memory-tests.lisp
|
||||
(defpackage :opencortex-memory-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:memory-suite))
|
||||
@@ -206,7 +206,7 @@ These tests verify the Memory system. Run with:
|
||||
** 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.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(defvar *memory-snapshot-path* nil
|
||||
"Path to the memory snapshot file. Set from MEMORY_SNAPSHOT_PATH env or default.")
|
||||
|
||||
@@ -261,7 +261,7 @@ Support for vector embeddings via Ollama and semantic search with cosine similar
|
||||
|
||||
The vector slot on org-objects enables semantic recall - searching memory by meaning rather than just keywords. Embeddings are generated on ingest when the :EMBED property is set to "t", and cached locally to avoid redundant API calls.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(defvar *embedding-cache* (make-hash-table :test 'equal)
|
||||
"Cache for embeddings to avoid redundant API calls.")
|
||||
|
||||
@@ -317,12 +317,35 @@ Returns up to LIMIT objects with similarity >= MIN-SIMILARITY, sorted by similar
|
||||
(semantic-search (getf args :query)
|
||||
:limit (or (getf args :limit) 10)
|
||||
:min-similarity (or (getf args :min-similarity) 0.5))))
|
||||
|
||||
** Cognitive Tool: Generate Embeddings
|
||||
Provided for the Probabilistic Engine to invoke embedding generation on demand.
|
||||
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(def-cognitive-tool :generate-embeddings
|
||||
"Generates vector embeddings for given text via the configured embedding backend (Ollama)."
|
||||
((:texts :type :list :description "List of text strings to embed."))
|
||||
:body (lambda (args)
|
||||
(let ((texts (getf args :texts)))
|
||||
(unless (and texts (listp texts))
|
||||
(return-from generate-embeddings
|
||||
(list :status :error :message ":texts must be a list of strings.")))
|
||||
(let ((results nil) (errors nil))
|
||||
(dolist (text texts)
|
||||
(let ((vec (get-embedding text)))
|
||||
(if vec
|
||||
(push (list :text text :vector vec) results)
|
||||
(push text errors))))
|
||||
(list :status (if errors :partial :success)
|
||||
:embeddings (nreverse results)
|
||||
:failed (when errors (nreverse errors))
|
||||
:count (length results))))))
|
||||
#+end_src
|
||||
|
||||
** Lookup Utilities
|
||||
Basic functions for retrieving objects by ID or type.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(defun org-id-new ()
|
||||
"Generates a new UUID string for Org-mode identification."
|
||||
(string-downcase (format nil "~a" (uuid:make-v4-uuid))))
|
||||
@@ -351,7 +374,7 @@ Basic functions for retrieving objects by ID or type.
|
||||
** Structural Helpers
|
||||
Utility functions for AST traversal and path resolution.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
#+begin_src lisp :tangle ./memory.lisp
|
||||
(defun find-headline-missing-id (ast)
|
||||
"Traverses an AST to find headlines that lack an :ID: property."
|
||||
(when (listp ast)
|
||||
@@ -367,7 +390,7 @@ Utility functions for AST traversal and path resolution.
|
||||
* Phase E: Chaos (Verification)
|
||||
Following the Engineering Standards, the Memory must be empirically verified through automated testing. The following test suite ensures the mathematical integrity of the Merkle hashes and the behavioral correctness of the immutable versioning and rollback systems.
|
||||
|
||||
#+begin_src lisp :tangle ../tests/memory-tests.lisp
|
||||
#+begin_src lisp :tangle ./tests/memory-tests.lisp
|
||||
(defpackage :opencortex-memory-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:memory-suite))
|
||||
|
||||
174
harness/package.lisp
Normal file
174
harness/package.lisp
Normal file
@@ -0,0 +1,174 @@
|
||||
(defpackage :opencortex
|
||||
(:use :cl)
|
||||
(:export
|
||||
;; --- communication protocol ---
|
||||
#:frame-message
|
||||
#:read-framed-message
|
||||
#:PROTO-GET
|
||||
#:LIST-OBJECTS-WITH-ATTRIBUTE
|
||||
#:COSINE-SIMILARITY
|
||||
#:VAULT-MASK-STRING
|
||||
#:*VAULT-MEMORY*
|
||||
#:parse-message
|
||||
#:make-hello-message
|
||||
#:validate-communication-protocol-schema
|
||||
|
||||
;; --- Daemon Lifecycle ---
|
||||
#:start-daemon
|
||||
#:stop-daemon
|
||||
#:harness-log
|
||||
#:main
|
||||
|
||||
;; --- Memory (CLOSOS) ---
|
||||
#:ingest-ast
|
||||
#:lookup-object
|
||||
#:list-objects-by-type
|
||||
#:org-id-new
|
||||
#:*memory*
|
||||
#:*history-store*
|
||||
#:org-object
|
||||
#:make-org-object
|
||||
#:org-object-id
|
||||
#:org-object-type
|
||||
#:org-object-attributes
|
||||
#:org-object-parent-id
|
||||
#:org-object-children
|
||||
#:org-object-version
|
||||
#:org-object-last-sync
|
||||
#:org-object-vector
|
||||
#:org-object-content
|
||||
#:org-object-hash
|
||||
#:snapshot-memory
|
||||
#:rollback-memory
|
||||
|
||||
;; --- Context API (Peripheral Vision) ---
|
||||
#:context-query-store
|
||||
#:context-get-active-projects
|
||||
#:context-get-recent-completed-tasks
|
||||
#:context-list-all-skills
|
||||
#:context-get-skill-source
|
||||
#:context-get-system-logs
|
||||
#:context-resolve-path
|
||||
#:context-get-skill-telemetry
|
||||
#:harness-track-telemetry
|
||||
#:context-assemble-global-awareness
|
||||
|
||||
;; --- Reactive Signal Pipeline ---
|
||||
#:process-signal
|
||||
#:perceive-gate
|
||||
#:probabilistic-gate
|
||||
#:consensus-gate
|
||||
#:act-gate
|
||||
#:reason-gate
|
||||
#:perceive-gate
|
||||
#:dispatch-gate
|
||||
#:inject-stimulus
|
||||
#:initialize-actuators
|
||||
#:dispatch-action
|
||||
#:register-actuator
|
||||
|
||||
;; --- Skill Engine ---
|
||||
#:load-skill-from-org
|
||||
#:initialize-all-skills
|
||||
#:load-skill-with-timeout
|
||||
#:topological-sort-skills
|
||||
#:validate-lisp-syntax
|
||||
#:defskill
|
||||
#:*skills-registry*
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-dependencies
|
||||
#:skill-trigger-fn
|
||||
#:skill-probabilistic-prompt
|
||||
#:skill-deterministic-fn
|
||||
|
||||
;; --- Tool Registry ---
|
||||
#:def-cognitive-tool
|
||||
#:*cognitive-tools*
|
||||
#:cognitive-tool
|
||||
#:cognitive-tool-name
|
||||
#:cognitive-tool-description
|
||||
#:cognitive-tool-parameters
|
||||
#:cognitive-tool-guard
|
||||
#:cognitive-tool-body
|
||||
|
||||
;; --- Emacs Client Registry ---
|
||||
#:*emacs-clients*
|
||||
#:*clients-lock*
|
||||
#:register-emacs-client
|
||||
#:unregister-emacs-client
|
||||
|
||||
;; --- Probabilistic Engine ---
|
||||
#:ask-probabilistic
|
||||
#:register-probabilistic-backend
|
||||
#:distill-prompt
|
||||
#:*provider-cascade*
|
||||
|
||||
;; --- Security Vault ---
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
|
||||
;; --- Deterministic Logic ---
|
||||
#:list-objects-with-attribute
|
||||
#:deterministic-verify
|
||||
|
||||
;; --- AST Helpers ---
|
||||
#:find-headline-missing-id))
|
||||
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
"Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
|
||||
(defvar *system-logs* nil)
|
||||
(defvar *logs-lock* (bordeaux-threads:make-lock "harness-logs-lock"))
|
||||
(defvar *max-log-history* 100)
|
||||
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded skills.")
|
||||
|
||||
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
|
||||
|
||||
(defun harness-track-telemetry (skill-name duration status)
|
||||
"Updates performance metrics for a specific skill. Status should be :success or :rejected."
|
||||
(when skill-name
|
||||
(bordeaux-threads:with-lock-held (*telemetry-lock*)
|
||||
(let ((entry (or (gethash skill-name *skill-telemetry*) (list :executions 0 :total-time 0 :failures 0))))
|
||||
(incf (getf entry :executions))
|
||||
(incf (getf entry :total-time) duration)
|
||||
(when (eq status :rejected) (incf (getf entry :failures)))
|
||||
(setf (gethash skill-name *skill-telemetry*) entry)))))
|
||||
|
||||
(defvar *cognitive-tools* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct cognitive-tool
|
||||
name
|
||||
description
|
||||
parameters
|
||||
guard
|
||||
body)
|
||||
|
||||
(defmacro def-cognitive-tool (name description parameters &key guard body)
|
||||
"Registers a new cognitive tool into the global registry. Parameters must be a list of property lists."
|
||||
`(setf (gethash (string-downcase (string ',name)) *cognitive-tools*)
|
||||
(make-cognitive-tool :name (string-downcase (string ',name))
|
||||
:description ,description
|
||||
:parameters ',parameters
|
||||
:guard ,guard
|
||||
:body ,body)))
|
||||
|
||||
(defun harness-log (msg &rest args)
|
||||
"Centralized logging for the harness."
|
||||
(let ((formatted-msg (apply #'format nil msg args)))
|
||||
(bordeaux-threads:with-lock-held (*logs-lock*)
|
||||
(push formatted-msg *system-logs*)
|
||||
(when (> (length *system-logs*) *max-log-history*)
|
||||
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||
(format t "~a~%" formatted-msg)
|
||||
(finish-output)))
|
||||
@@ -9,7 +9,7 @@ The ~package.lisp~ file defines the public API of the ~opencortex~ harness. It s
|
||||
|
||||
** Public API Export
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
#+begin_src lisp :tangle ./package.lisp
|
||||
(defpackage :opencortex
|
||||
(:use :cl)
|
||||
(:export
|
||||
@@ -131,13 +131,13 @@ The ~package.lisp~ file defines the public API of the ~opencortex~ harness. It s
|
||||
|
||||
* Package Implementation
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
#+begin_src lisp :tangle ./package.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Robust Plist Accessor
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
#+begin_src lisp :tangle ./package.lisp
|
||||
(defun proto-get (plist key)
|
||||
"Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
|
||||
(let* ((s (string key))
|
||||
@@ -150,7 +150,7 @@ The ~package.lisp~ file defines the public API of the ~opencortex~ harness. It s
|
||||
|
||||
The harness maintains a thread-safe circular log buffer to provide context for debugging and neural reasoning.
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
#+begin_src lisp :tangle ./package.lisp
|
||||
(defvar *system-logs* nil)
|
||||
(defvar *logs-lock* (bordeaux-threads:make-lock "harness-logs-lock"))
|
||||
(defvar *max-log-history* 100)
|
||||
@@ -158,14 +158,14 @@ The harness maintains a thread-safe circular log buffer to provide context for d
|
||||
|
||||
** Skills Registry
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
#+begin_src lisp :tangle ./package.lisp
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded skills.")
|
||||
#+end_src
|
||||
|
||||
** Skill Telemetry State
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
#+begin_src lisp :tangle ./package.lisp
|
||||
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
|
||||
#+end_src
|
||||
@@ -174,7 +174,7 @@ The harness maintains a thread-safe circular log buffer to provide context for d
|
||||
|
||||
The system tracks the performance and reliability of individual skills.
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
#+begin_src lisp :tangle ./package.lisp
|
||||
(defun harness-track-telemetry (skill-name duration status)
|
||||
"Updates performance metrics for a specific skill. Status should be :success or :rejected."
|
||||
(when skill-name
|
||||
@@ -190,7 +190,7 @@ The system tracks the performance and reliability of individual skills.
|
||||
|
||||
The Tool Registry allows the agent to interact with the physical world. Every tool must define a guard (for security) and a body (for execution).
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
#+begin_src lisp :tangle ./package.lisp
|
||||
(defvar *cognitive-tools* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct cognitive-tool
|
||||
@@ -214,7 +214,7 @@ The Tool Registry allows the agent to interact with the physical world. Every to
|
||||
|
||||
Centralized logging function. It simultaneously writes to standard output and the in-memory circular buffer.
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
#+begin_src lisp :tangle ./package.lisp
|
||||
(defun harness-log (msg &rest args)
|
||||
"Centralized logging for the harness."
|
||||
(let ((formatted-msg (apply #'format nil msg args)))
|
||||
|
||||
130
harness/perceive.lisp
Normal file
130
harness/perceive.lisp
Normal file
@@ -0,0 +1,130 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *async-sensors* '(:chat-message :delegation :user-command)
|
||||
"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.
|
||||
|
||||
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))
|
||||
"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 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
|
||||
;; 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")
|
||||
|
||||
;; 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)
|
||||
"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)))
|
||||
|
||||
;; 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
|
||||
|
||||
;; 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 moved to different org node - update focus
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element
|
||||
(snapshot-memory)
|
||||
;; Track foveal focus for contextual reasoning
|
||||
(setf *foveal-focus-id*
|
||||
(ignore-errors (getf element :id)))
|
||||
(ingest-ast element))))
|
||||
|
||||
;; 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))))
|
||||
|
||||
;; Update signal status
|
||||
(setf (getf signal :status) :perceived)
|
||||
(setf (getf signal :foveal-focus) *foveal-focus-id*)
|
||||
signal))
|
||||
@@ -53,7 +53,7 @@ Other sensors (heartbeats, interrupts) are processed synchronously to maintain o
|
||||
|
||||
* Package Context
|
||||
|
||||
#+begin_src lisp :tangle ../library/perceive.lisp
|
||||
#+begin_src lisp :tangle ./perceive.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
@@ -61,7 +61,7 @@ Other sensors (heartbeats, interrupts) are processed synchronously to maintain o
|
||||
|
||||
** Async Sensor Registry
|
||||
|
||||
#+begin_src lisp :tangle ../library/perceive.lisp
|
||||
#+begin_src lisp :tangle ./perceive.lisp
|
||||
(defvar *async-sensors* '(:chat-message :delegation :user-command)
|
||||
"Sensors that are processed in dedicated threads.
|
||||
|
||||
@@ -74,7 +74,7 @@ Other sensors (heartbeats, interrupts) are processed synchronously to maintain o
|
||||
|
||||
** Foveal Focus State
|
||||
|
||||
#+begin_src lisp :tangle ../library/perceive.lisp
|
||||
#+begin_src lisp :tangle ./perceive.lisp
|
||||
(defvar *foveal-focus-id* nil
|
||||
"The Org ID of the node the user is currently interacting with.
|
||||
|
||||
@@ -89,7 +89,7 @@ Other sensors (heartbeats, interrupts) are processed synchronously to maintain o
|
||||
|
||||
** inject-stimulus: Entry Point
|
||||
|
||||
#+begin_src lisp :tangle ../library/perceive.lisp
|
||||
#+begin_src lisp :tangle ./perceive.lisp
|
||||
(defun inject-stimulus (raw-message &key stream (depth 0))
|
||||
"Inject a raw message into the signal processing pipeline.
|
||||
|
||||
@@ -146,7 +146,7 @@ Other sensors (heartbeats, interrupts) are processed synchronously to maintain o
|
||||
|
||||
** perceive-gate: Signal Normalization
|
||||
|
||||
#+begin_src lisp :tangle ../library/perceive.lisp
|
||||
#+begin_src lisp :tangle ./perceive.lisp
|
||||
(defun perceive-gate (signal)
|
||||
"Stage 1 of the metabolic pipeline: Normalize sensory input.
|
||||
|
||||
@@ -226,7 +226,7 @@ Other sensors (heartbeats, interrupts) are processed synchronously to maintain o
|
||||
These tests verify the Perceive pipeline. Run with:
|
||||
~(fiveam:run! 'pipeline-perceive-suite)~
|
||||
|
||||
#+begin_src lisp :tangle ../tests/pipeline-perceive-tests.lisp
|
||||
#+begin_src lisp :tangle ./tests/pipeline-perceive-tests.lisp
|
||||
(defpackage :opencortex-pipeline-perceive-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:pipeline-perceive-suite))
|
||||
|
||||
361
harness/reason.lisp
Normal file
361
harness/reason.lisp
Normal file
@@ -0,0 +1,361 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(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)
|
||||
"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))
|
||||
"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)
|
||||
|
||||
;; 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))))))))
|
||||
|
||||
;; All providers failed
|
||||
(list :type :LOG
|
||||
:payload (list :text "Neural Cascade Failure: All providers exhausted.")))))
|
||||
|
||||
(defun strip-markdown (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 ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
|
||||
(string-trim '(#\Space #\Newline #\Tab) cleaned))
|
||||
text))
|
||||
|
||||
(defun normalize-plist-keywords (plist)
|
||||
"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)))
|
||||
(intern (string k) :keyword)
|
||||
k)
|
||||
collect (car rest))))
|
||||
|
||||
(defun think (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")))
|
||||
|
||||
;; 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
|
||||
|
||||
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.
|
||||
|
||||
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)))
|
||||
|
||||
(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 (char= (char cleaned 0) #\()
|
||||
;; Response starts with paren - try to parse as plist
|
||||
(handler-case
|
||||
(let ((parsed (read-from-string 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)
|
||||
"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))
|
||||
|
||||
;; 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)))
|
||||
|
||||
;; 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)))
|
||||
|
||||
;; 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))))
|
||||
|
||||
;; 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)
|
||||
"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)))
|
||||
|
||||
;; 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 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))
|
||||
(setf (getf signal :approved-action) nil)))
|
||||
|
||||
(setf (getf signal :status) :reasoned)
|
||||
signal)))
|
||||
@@ -33,7 +33,7 @@ This means the reasoning pipeline can generate, modify, and execute its own comm
|
||||
|
||||
* Package Context
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
#+begin_src lisp :tangle ./reason.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
@@ -43,7 +43,7 @@ The probabilistic engine is responsible for all neural/LLM operations. It mainta
|
||||
|
||||
** Backend Registry Variables
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
#+begin_src lisp :tangle ./reason.lisp
|
||||
(defvar *probabilistic-backends* (make-hash-table :test 'equal)
|
||||
"Registry mapping provider keywords (:openrouter, :ollama) to their calling functions.")
|
||||
|
||||
@@ -60,7 +60,7 @@ The probabilistic engine is responsible for all neural/LLM operations. It mainta
|
||||
|
||||
** register-probabilistic-backend: Backend Registration
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
#+begin_src lisp :tangle ./reason.lisp
|
||||
(defun register-probabilistic-backend (name fn)
|
||||
"Register a neural provider backend.
|
||||
|
||||
@@ -79,7 +79,7 @@ The probabilistic engine is responsible for all neural/LLM operations. It mainta
|
||||
|
||||
** probabilistic-call: Cascade Dispatch
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
#+begin_src lisp :tangle ./reason.lisp
|
||||
(defun probabilistic-call (prompt &key
|
||||
(system-prompt "You are the Probabilistic engine.")
|
||||
(cascade nil)
|
||||
@@ -129,7 +129,7 @@ The `think` function is the heart of the probabilistic engine. It constructs a p
|
||||
|
||||
** strip-markdown: Clean LLM Output
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
#+begin_src lisp :tangle ./reason.lisp
|
||||
(defun strip-markdown (text)
|
||||
"Strip markdown formatting from LLM output.
|
||||
|
||||
@@ -152,7 +152,7 @@ The `think` function is the heart of the probabilistic engine. It constructs a p
|
||||
|
||||
** normalize-plist-keywords: Fix LLM Keyword Output
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
#+begin_src lisp :tangle ./reason.lisp
|
||||
(defun normalize-plist-keywords (plist)
|
||||
"Normalize all keys in a plist to keywords.
|
||||
|
||||
@@ -176,7 +176,7 @@ The `think` function is the heart of the probabilistic engine. It constructs a p
|
||||
|
||||
** think: Generate Action Proposal
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
#+begin_src lisp :tangle ./reason.lisp
|
||||
(defun think (context)
|
||||
"Generate a Lisp action proposal based on current context.
|
||||
|
||||
@@ -320,7 +320,7 @@ The deterministic engine runs all registered skills' verification functions. Thi
|
||||
|
||||
** deterministic-verify: Skill Chain Verification
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
#+begin_src lisp :tangle ./reason.lisp
|
||||
(defun deterministic-verify (proposed-action context)
|
||||
"Run all skill deterministic gates on a proposed action.
|
||||
|
||||
@@ -391,7 +391,7 @@ The deterministic engine runs all registered skills' verification functions. Thi
|
||||
|
||||
** reason-gate: The Stage Function
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
#+begin_src lisp :tangle ./reason.lisp
|
||||
(defun reason-gate (signal)
|
||||
"Stage 2 of the metabolic pipeline: Reason.
|
||||
|
||||
@@ -448,7 +448,7 @@ The deterministic engine runs all registered skills' verification functions. Thi
|
||||
These tests verify the Reason (cognitive) pipeline. Run with:
|
||||
~(fiveam:run! 'pipeline-reason-suite)~
|
||||
|
||||
#+begin_src lisp :tangle ../tests/pipeline-reason-tests.lisp
|
||||
#+begin_src lisp :tangle ./tests/pipeline-reason-tests.lisp
|
||||
(defpackage :opencortex-pipeline-reason-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:pipeline-reason-suite))
|
||||
|
||||
435
harness/skills.lisp
Normal file
435
harness/skills.lisp
Normal file
@@ -0,0 +1,435 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun COSINE-SIMILARITY (v1 v2)
|
||||
"Computes the cosine similarity between two vectors."
|
||||
(let* ((len1 (length v1))
|
||||
(len2 (length v2)))
|
||||
(if (or (zerop len1) (zerop len2))
|
||||
0.0
|
||||
(let* ((dot-product 0.0d0)
|
||||
(norm1 0.0d0)
|
||||
(norm2 0.0d0))
|
||||
(dotimes (i (min len1 len2))
|
||||
(let* ((x (coerce (elt v1 i) 'double-float))
|
||||
(y (coerce (elt v2 i) 'double-float)))
|
||||
(incf dot-product (* x y))
|
||||
(incf norm1 (* x x))
|
||||
(incf norm2 (* y y))))
|
||||
(if (or (zerop norm1) (zerop norm2))
|
||||
0.0
|
||||
(/ dot-product (sqrt (* norm1 norm2))))))))
|
||||
|
||||
;; TODO: Stub for vault - implement later
|
||||
(defun VAULT-MASK-STRING (s) "[MASKED]")
|
||||
|
||||
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
|
||||
|
||||
|
||||
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn)
|
||||
|
||||
(defvar *skill-catalog* (make-hash-table :test 'equal)
|
||||
"A stateful tracking table for all skill files discovered in the environment.")
|
||||
|
||||
(defstruct skill-entry
|
||||
filename
|
||||
(status :discovered) ;; :discovered, :loading, :ready, :failed
|
||||
error-log
|
||||
(load-time 0))
|
||||
|
||||
(defun find-triggered-skill (context)
|
||||
"Returns the highest priority skill whose trigger matches context AND has a probabilistic prompt."
|
||||
(let ((triggered nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (and (skill-probabilistic-prompt skill)
|
||||
(ignore-errors (funcall (skill-trigger-fn skill) context)))
|
||||
(push skill triggered)))
|
||||
*skills-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
|
||||
(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic)
|
||||
"Registers a new skill into the global registry."
|
||||
`(setf (gethash (string-downcase (string ,name)) *skills-registry*)
|
||||
(make-skill :name (string-downcase (string ,name))
|
||||
:priority (or ,priority 10)
|
||||
:dependencies ',dependencies
|
||||
:trigger-fn ,trigger
|
||||
:probabilistic-prompt ,probabilistic
|
||||
:deterministic-fn ,deterministic)))
|
||||
|
||||
(defun resolve-skill-dependencies (skill-name)
|
||||
"Recursively resolves dependencies for a given skill name."
|
||||
(let ((resolved nil) (seen nil))
|
||||
(labels ((visit (name)
|
||||
(unless (member name seen :test #'equal)
|
||||
(push name seen)
|
||||
(let ((skill (gethash (string-downcase (string name)) *skills-registry*)))
|
||||
(when skill
|
||||
(dolist (dep (skill-dependencies skill))
|
||||
(visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name)
|
||||
(nreverse resolved))))
|
||||
|
||||
(defun parse-skill-metadata (filepath)
|
||||
"Extracts ID and DEPENDS_ON tags from org file."
|
||||
(let ((dependencies nil)
|
||||
(id nil)
|
||||
(content (uiop:read-file-string filepath)))
|
||||
;; Simple ID extraction using string search
|
||||
(let ((id-start (search ":ID:" content)))
|
||||
(when id-start
|
||||
(let ((id-end (position #\Newline content :start id-start)))
|
||||
(when id-end
|
||||
(setf id (subseq content (+ id-start 4) id-end)))))
|
||||
;; Simple DEPENDS_ON extraction
|
||||
(let ((pos 0))
|
||||
(loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos))
|
||||
do (let ((end (position #\Newline content :start pos)))
|
||||
(when end
|
||||
(push (subseq content (+ pos 13) end) dependencies)
|
||||
(setf pos end))))
|
||||
(values id (reverse dependencies))))
|
||||
|
||||
(defun topological-sort-skills (skills-dir)
|
||||
"Returns a list of skill filepaths sorted by dependency (dependencies first)."
|
||||
(let ((files (uiop:directory-files skills-dir "org-skill-*.org"))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
(id-to-file (make-hash-table :test 'equal))
|
||||
(result nil)
|
||||
(visited (make-hash-table :test 'equal))
|
||||
(stack (make-hash-table :test 'equal)))
|
||||
(dolist (file files)
|
||||
(let ((filename (pathname-name file)))
|
||||
(multiple-value-bind (id deps) (parse-skill-metadata file)
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
(when id (setf (gethash (string-downcase id) id-to-file) file))
|
||||
(setf (gethash (string-downcase filename) adj) deps))))
|
||||
(labels ((visit (file)
|
||||
(let* ((filename (pathname-name file))
|
||||
(node-key (string-downcase filename)))
|
||||
(unless (gethash node-key visited)
|
||||
(setf (gethash node-key stack) t)
|
||||
(dolist (dep (gethash node-key adj))
|
||||
(let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep)))
|
||||
(dep-key (string-downcase (if is-id-p (subseq dep 3) dep)))
|
||||
(dep-file (if is-id-p
|
||||
(gethash dep-key id-to-file)
|
||||
(or (gethash dep-key id-to-file)
|
||||
(gethash dep-key name-to-file)))))
|
||||
(when dep-file
|
||||
(let ((dep-filename (pathname-name dep-file)))
|
||||
(if (gethash (string-downcase dep-filename) stack)
|
||||
(error "Circular dependency detected: ~a -> ~a" filename dep-filename)
|
||||
(visit dep-file))))))
|
||||
(setf (gethash node-key stack) nil)
|
||||
(setf (gethash node-key visited) t)
|
||||
(push file result)))))
|
||||
(let ((filenames (sort (mapcar #'pathname-name files) #'string<)))
|
||||
(dolist (name filenames)
|
||||
(let ((file (gethash (string-downcase name) name-to-file)))
|
||||
(when file (visit file)))))
|
||||
(nreverse result))))
|
||||
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
"Checks if a string contains valid, readable Common Lisp forms.
|
||||
Delegates to the Lisp Validator skill when available; falls back to a basic
|
||||
reader check during early boot before the validator skill is loaded."
|
||||
(let ((result
|
||||
(if (fboundp 'lisp-validator-validate)
|
||||
(lisp-validator-validate code-string :strict nil)
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof) until (eq form :eof)))
|
||||
(list :status :success))
|
||||
(error (c)
|
||||
(list :status :error :reason (format nil "~a" c)))))))
|
||||
(if (eq (getf result :status) :success)
|
||||
(values t nil)
|
||||
(values nil (or (getf result :reason) "Lisp Validator rejected code.")))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses and evaluates Lisp blocks with :tangle directives from an Org file.
|
||||
Only loads blocks that specify a .lisp tangle target, ignoring tests and examples."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(setf (gethash skill-base-name *skill-catalog*) entry)
|
||||
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil)
|
||||
(collect-this-block nil)
|
||||
(lisp-code "")
|
||||
(pkg-name (intern (string-upcase (format nil "OPENCORTEX.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond ((uiop:string-prefix-p "#+begin_src lisp" (string-downcase clean-line))
|
||||
(setf in-lisp-block t)
|
||||
;; Only collect blocks with a :tangle directive pointing to a
|
||||
;; runtime .lisp file (exclude tests and :tangle no)
|
||||
(let ((tl (string-downcase clean-line)))
|
||||
(setf collect-this-block
|
||||
(and (search ":tangle" tl)
|
||||
(not (search ":tangle no" tl))
|
||||
(search ".lisp" tl)
|
||||
(not (search "tests/" tl))
|
||||
(not (search "test/" tl))))))
|
||||
((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)))
|
||||
(setf lisp-code (concatenate 'string lisp-code line (string #\Newline)))))))
|
||||
|
||||
(if (= (length lisp-code) 0)
|
||||
(progn (setf (skill-entry-status entry) :ready) t)
|
||||
(progn
|
||||
(multiple-value-bind (valid-p err) (validate-lisp-syntax lisp-code)
|
||||
(unless valid-p (error "Syntax Error: ~a" err)))
|
||||
(harness-log "HARNESS: Jailing skill '~a' in package ~a" skill-base-name pkg-name)
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl))))
|
||||
(use-package :opencortex new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
||||
(setf (skill-entry-status entry) :ready)
|
||||
t)))
|
||||
(error (c)
|
||||
(let ((msg (format nil "~a" c)))
|
||||
(harness-log "LOADER ERROR in skill '~a': ~a" skill-base-name msg)
|
||||
(setf (skill-entry-status entry) :failed)
|
||||
(setf (skill-entry-error-log entry) msg)
|
||||
nil)))
|
||||
|
||||
(defun load-skill-with-timeout (filepath timeout-seconds)
|
||||
"Loads a skill Org file with a hard execution timeout."
|
||||
(let* ((finished nil)
|
||||
(thread (bt:make-thread (lambda ()
|
||||
(if (load-skill-from-org filepath)
|
||||
(setf finished t)
|
||||
(setf finished :error)))
|
||||
:name (format nil "loader-~a" (pathname-name filepath))))
|
||||
(start-time (get-internal-real-time))
|
||||
(timeout-units (truncate (* timeout-seconds internal-time-units-per-second))))
|
||||
(loop
|
||||
(when (eq finished t) (return :success))
|
||||
(when (eq finished :error) (return :error))
|
||||
(unless (bt:thread-alive-p thread) (return :error))
|
||||
(when (> (- (get-internal-real-time) start-time) timeout-units)
|
||||
(harness-log "HARNESS: Timing out skill ~a..." (pathname-name filepath))
|
||||
#+sbcl (sb-thread:terminate-thread thread)
|
||||
#-sbcl (bt:destroy-thread thread)
|
||||
(return :timeout))
|
||||
(sleep 0.05))))
|
||||
|
||||
(defun initialize-all-skills ()
|
||||
"Scans the directory defined by SKILLS_DIR and hot-loads skills using topological order."
|
||||
(let* ((env-path (uiop:getenv "SKILLS_DIR"))
|
||||
(skills-dir-str (or env-path (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))
|
||||
(resolved-path (context-resolve-path skills-dir-str))
|
||||
(skills-dir (if resolved-path (uiop:ensure-directory-pathname resolved-path) nil)))
|
||||
|
||||
(unless (and skills-dir (uiop:directory-exists-p skills-dir))
|
||||
(harness-log "HARNESS ERROR: Skills directory not found: ~a" skills-dir-str)
|
||||
(return-from initialize-all-skills nil))
|
||||
|
||||
(let ((sorted-files (topological-sort-skills skills-dir)))
|
||||
(let* ((mandatory-env (uiop:getenv "MANDATORY_SKILLS"))
|
||||
(mandatory-skills (if mandatory-env
|
||||
(mapcar (lambda (s) (string-trim '(#\Space #\" #\') s))
|
||||
(uiop:split-string mandatory-env :separator '( #\,)))
|
||||
'("org-skill-policy" "org-skill-bouncer"))))
|
||||
(dolist (req mandatory-skills)
|
||||
(unless (member req sorted-files :key #'pathname-name :test #'string-equal)
|
||||
(error "BOOT FAILURE: Mandatory skill '~a' not found in skills directory: ~a" req (uiop:native-namestring skills-dir))))
|
||||
|
||||
(harness-log "==================================================")
|
||||
(harness-log " LOADER: Initializing ~a skills..." (length sorted-files))
|
||||
|
||||
(dolist (file sorted-files)
|
||||
(let* ((skill-name (pathname-name file))
|
||||
(is-mandatory (member skill-name mandatory-skills :test #'string-equal)))
|
||||
(harness-log " LOADER: Loading ~a..." skill-name)
|
||||
(let ((status (load-skill-with-timeout file 5)))
|
||||
(unless (eq status :success)
|
||||
(if is-mandatory
|
||||
(error "BOOT FAILURE: Mandatory skill '~a' failed to load (Status: ~a)." skill-name status)
|
||||
(harness-log "LOADER WARNING: Skill '~a' failed to load." skill-name))))))
|
||||
|
||||
(let ((ready 0) (failed 0))
|
||||
(maphash (lambda (k v)
|
||||
(declare (ignore k))
|
||||
(if (eq (skill-entry-status v) :ready) (incf ready) (incf failed)))
|
||||
*skill-catalog*)
|
||||
(harness-log " LOADER: Boot Complete. [Ready: ~a] [Failed: ~a]" ready failed)
|
||||
(harness-log "==================================================")
|
||||
(values ready failed))))))
|
||||
|
||||
(defun generate-tool-belt-prompt ()
|
||||
"Aggregates all registered cognitive tools into a descriptive prompt."
|
||||
(let ((output (format nil "AVAILABLE TOOLS:
|
||||
You can call tools by returning a Lisp plist: (:target :tool :action :call :tool <name> :args (...))
|
||||
|
||||
EXAMPLES:
|
||||
(:target :tool :action :call :tool \"eval\" :args (:code \"(+ 1 1)\"))
|
||||
(:target :tool :action :call :tool \"grep-search\" :args (:pattern \"autonomousty\"))
|
||||
(:target :tool :action :call :tool \"shell\" :args (:cmd \"ls -la\"))
|
||||
|
||||
---
|
||||
" )))
|
||||
(maphash (lambda (name tool)
|
||||
(setf output (concatenate 'string output
|
||||
(format nil "- ~a: ~a~% Parameters: ~s~%~%"
|
||||
name
|
||||
(cognitive-tool-description tool)
|
||||
(cognitive-tool-parameters tool)))))
|
||||
*cognitive-tools*)
|
||||
output))
|
||||
|
||||
(def-cognitive-tool :eval "Evaluates raw Common Lisp code in the harness image. Use this for complex calculations or internal state inspection."
|
||||
((:code :type :string :description "The Lisp code to evaluate"))
|
||||
:guard (lambda (args context)
|
||||
(declare (ignore context))
|
||||
(let ((code (getf args :code)))
|
||||
(let ((harness-pkg (find-package :opencortex.skills.org-skill-lisp-validator)))
|
||||
(if harness-pkg
|
||||
(uiop:symbol-call :opencortex.skills.org-skill-lisp-validator :lisp-validator-validate code)
|
||||
t))))
|
||||
:body (lambda (args)
|
||||
(let ((code (getf args :code)))
|
||||
(handler-case (let ((result (eval (read-from-string code))))
|
||||
(format nil "~s" result))
|
||||
(error (c) (format nil "ERROR: ~a" c))))))
|
||||
|
||||
(def-cognitive-tool :grep-search "Searches for a pattern in the project files."
|
||||
((:pattern :type :string :description "The regex pattern to search for")
|
||||
(:dir :type :string :description "Directory to search in (default is project root)"))
|
||||
:body (lambda (args)
|
||||
(let ((pattern (getf args :pattern))
|
||||
(dir (or (getf args :dir) (uiop:getenv "MEMEX_DIR"))))
|
||||
(uiop:run-program (list "grep" "-r" "-n" "--exclude-dir=node_modules" pattern dir)
|
||||
:output :string :ignore-error-status t))))
|
||||
|
||||
(def-cognitive-tool :shell "Executes a shell command on the local machine. Use this for file operations, system checks, or running tests."
|
||||
((:cmd :type :string :description "The full bash command to execute"))
|
||||
:guard (lambda (args context)
|
||||
(declare (ignore context))
|
||||
(let ((cmd (getf args :cmd)))
|
||||
(not (or (search "rm -rf /" cmd) (search ":(){ :|:& };:" cmd)))))
|
||||
:body (lambda (args)
|
||||
(let ((cmd (getf args :cmd)))
|
||||
(multiple-value-bind (out err code)
|
||||
(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)))))
|
||||
|
||||
(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 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, 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 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))))))
|
||||
@@ -10,29 +10,31 @@ A static, hardcoded architecture is inherently fragile. The ~opencortex~ Skill E
|
||||
|
||||
** Global Skill Registry
|
||||
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun COSINE-SIMILARITY (v1 v2)
|
||||
"Computes the cosine similarity between two vectors.
|
||||
Both arguments should be sequences of numbers. Returns a value between -1.0 and 1.0."
|
||||
(let ((len1 (length v1)) (len2 (length v2)))
|
||||
"Computes the cosine similarity between two vectors."
|
||||
(let* ((len1 (length v1))
|
||||
(len2 (length v2)))
|
||||
(if (or (zerop len1) (zerop len2))
|
||||
0.0
|
||||
(let ((dot-product 0.0d0)
|
||||
(norm1 0.0d0)
|
||||
(norm2 0.0d0))
|
||||
(let ((len (min len1 len2)))
|
||||
(dotimes (i len)
|
||||
(let ((x (coerce (elt v1 i) 'double-float)))
|
||||
(let ((y (coerce (elt v2 i) 'double-float)))
|
||||
(incf dot-product (* x y))
|
||||
(incf norm1 (* x x))
|
||||
(incf norm2 (* y y))))))
|
||||
(let* ((dot-product 0.0d0)
|
||||
(norm1 0.0d0)
|
||||
(norm2 0.0d0))
|
||||
(dotimes (i (min len1 len2))
|
||||
(let* ((x (coerce (elt v1 i) 'double-float))
|
||||
(y (coerce (elt v2 i) 'double-float)))
|
||||
(incf dot-product (* x y))
|
||||
(incf norm1 (* x x))
|
||||
(incf norm2 (* y y))))
|
||||
(if (or (zerop norm1) (zerop norm2))
|
||||
0.0
|
||||
(/ dot-product (sqrt (* norm1 norm2))))))))
|
||||
(defun VAULT-MASK-STRING (s) "[MASKED]") ; Stub
|
||||
|
||||
;; TODO: Stub for vault - implement later
|
||||
(defun VAULT-MASK-STRING (s) "[MASKED]")
|
||||
|
||||
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
|
||||
|
||||
|
||||
@@ -62,11 +64,11 @@ Both arguments should be sequences of numbers. Returns a value between -1.0 and
|
||||
"Registers a new skill into the global registry."
|
||||
`(setf (gethash (string-downcase (string ,name)) *skills-registry*)
|
||||
(make-skill :name (string-downcase (string ,name))
|
||||
:priority (or ,priority 10)
|
||||
:dependencies ',dependencies
|
||||
:trigger-fn ,trigger
|
||||
:probabilistic-prompt ,probabilistic
|
||||
:deterministic-fn ,deterministic)))
|
||||
:priority (or ,priority 10)
|
||||
:dependencies ',dependencies
|
||||
:trigger-fn ,trigger
|
||||
:probabilistic-prompt ,probabilistic
|
||||
:deterministic-fn ,deterministic)))
|
||||
|
||||
(defun resolve-skill-dependencies (skill-name)
|
||||
"Recursively resolves dependencies for a given skill name."
|
||||
@@ -84,26 +86,30 @@ Both arguments should be sequences of numbers. Returns a value between -1.0 and
|
||||
#+end_src
|
||||
|
||||
** Skill File Analysis (parse-skill-metadata)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(defun parse-skill-metadata (filepath)
|
||||
"Extracts ID and DEPENDS_ON tags using robust regex scanning."
|
||||
"Extracts ID and DEPENDS_ON tags from org file."
|
||||
(let ((dependencies nil)
|
||||
(id nil)
|
||||
(content (uiop:read-file-string filepath)))
|
||||
;; Extract ID
|
||||
(multiple-value-bind (match regs)
|
||||
(ppcre:scan-to-strings "(?im:^:ID:\\s*([^\\s\\r\\n]+))" content)
|
||||
(when match (setf id (aref regs 0))))
|
||||
;; Extract all DEPENDS_ON lines
|
||||
(ppcre:do-register-groups (deps-string)
|
||||
("(?im:^#\\+DEPENDS_ON:\\s*(.*))" content)
|
||||
(let ((deps (ppcre:split "\\s+" (string-trim " " deps-string))))
|
||||
(setf dependencies (append dependencies (mapcar (lambda (s) (string-trim "[] " s)) deps)))))
|
||||
(values id (remove-if (lambda (s) (= 0 (length s))) dependencies))))
|
||||
;; Simple ID extraction using string search
|
||||
(let ((id-start (search ":ID:" content)))
|
||||
(when id-start
|
||||
(let ((id-end (position #\Newline content :start id-start)))
|
||||
(when id-end
|
||||
(setf id (subseq content (+ id-start 4) id-end)))))
|
||||
;; Simple DEPENDS_ON extraction
|
||||
(let ((pos 0))
|
||||
(loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos))
|
||||
do (let ((end (position #\Newline content :start pos)))
|
||||
(when end
|
||||
(push (subseq content (+ pos 13) end) dependencies)
|
||||
(setf pos end))))
|
||||
(values id (reverse dependencies))))
|
||||
#+end_src
|
||||
|
||||
** Dependency Resolution (topological-sort-skills)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(defun topological-sort-skills (skills-dir)
|
||||
"Returns a list of skill filepaths sorted by dependency (dependencies first)."
|
||||
(let ((files (uiop:directory-files skills-dir "org-skill-*.org"))
|
||||
@@ -147,7 +153,7 @@ Both arguments should be sequences of numbers. Returns a value between -1.0 and
|
||||
#+end_src
|
||||
|
||||
** Jailed Loading (load-skill-from-org)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
"Checks if a string contains valid, readable Common Lisp forms.
|
||||
Delegates to the Lisp Validator skill when available; falls back to a basic
|
||||
@@ -201,7 +207,7 @@ Only loads blocks that specify a .lisp tangle target, ignoring tests and example
|
||||
((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)))
|
||||
(setf lisp-code (concatenate 'string lisp-code line (string #\Newline))))))))
|
||||
(setf lisp-code (concatenate 'string lisp-code line (string #\Newline)))))))
|
||||
|
||||
(if (= (length lisp-code) 0)
|
||||
(progn (setf (skill-entry-status entry) :ready) t)
|
||||
@@ -221,7 +227,7 @@ Only loads blocks that specify a .lisp tangle target, ignoring tests and example
|
||||
(harness-log "LOADER ERROR in skill '~a': ~a" skill-base-name msg)
|
||||
(setf (skill-entry-status entry) :failed)
|
||||
(setf (skill-entry-error-log entry) msg)
|
||||
nil)))))
|
||||
nil)))
|
||||
|
||||
(defun load-skill-with-timeout (filepath timeout-seconds)
|
||||
"Loads a skill Org file with a hard execution timeout."
|
||||
@@ -246,7 +252,7 @@ Only loads blocks that specify a .lisp tangle target, ignoring tests and example
|
||||
#+end_src
|
||||
|
||||
** Initializing All Skills (initialize-all-skills)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(defun initialize-all-skills ()
|
||||
"Scans the directory defined by SKILLS_DIR and hot-loads skills using topological order."
|
||||
(let* ((env-path (uiop:getenv "SKILLS_DIR"))
|
||||
@@ -292,7 +298,7 @@ Only loads blocks that specify a .lisp tangle target, ignoring tests and example
|
||||
#+end_src
|
||||
|
||||
** Toolbelt Prompt Generation (generate-tool-belt-prompt)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(defun generate-tool-belt-prompt ()
|
||||
"Aggregates all registered cognitive tools into a descriptive prompt."
|
||||
(let ((output (format nil "AVAILABLE TOOLS:
|
||||
@@ -317,7 +323,7 @@ EXAMPLES:
|
||||
|
||||
** The Default Tool Belt
|
||||
*** The Eval Tool (Internal Inspection)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(def-cognitive-tool :eval "Evaluates raw Common Lisp code in the harness image. Use this for complex calculations or internal state inspection."
|
||||
((:code :type :string :description "The Lisp code to evaluate"))
|
||||
:guard (lambda (args context)
|
||||
@@ -335,7 +341,7 @@ EXAMPLES:
|
||||
#+end_src
|
||||
|
||||
*** The Grep Tool (File Discovery)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(def-cognitive-tool :grep-search "Searches for a pattern in the project files."
|
||||
((:pattern :type :string :description "The regex pattern to search for")
|
||||
(:dir :type :string :description "Directory to search in (default is project root)"))
|
||||
@@ -347,7 +353,7 @@ EXAMPLES:
|
||||
#+end_src
|
||||
|
||||
*** The Shell Tool (Machine Actuation)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(def-cognitive-tool :shell "Executes a shell command on the local machine. Use this for file operations, system checks, or running tests."
|
||||
((:cmd :type :string :description "The full bash command to execute"))
|
||||
:guard (lambda (args context)
|
||||
@@ -362,7 +368,7 @@ EXAMPLES:
|
||||
#+end_src
|
||||
|
||||
*** The Reload-Skill Tool (Hot Reload)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(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)
|
||||
@@ -398,7 +404,7 @@ EXAMPLES:
|
||||
#+end_src
|
||||
|
||||
*** The File Read Tool (V 0.2.0 File I/O)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(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)
|
||||
@@ -417,7 +423,7 @@ EXAMPLES:
|
||||
#+end_src
|
||||
|
||||
*** The File Write Tool (V 0.2.0 File I/O)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(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")
|
||||
@@ -449,7 +455,7 @@ EXAMPLES:
|
||||
#+end_src
|
||||
|
||||
*** The String Replace Tool (V 0.2.0 File I/O)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
#+begin_src lisp :tangle ./skills.lisp
|
||||
(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")
|
||||
@@ -484,7 +490,7 @@ EXAMPLES:
|
||||
These tests verify the Skill Engine and loader. Run with:
|
||||
~(fiveam:run! 'boot-suite)~
|
||||
|
||||
#+begin_src lisp :tangle ../tests/boot-sequence-tests.lisp
|
||||
#+begin_src lisp :tangle ./tests/boot-sequence-tests.lisp
|
||||
(defpackage :opencortex-boot-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:boot-suite))
|
||||
|
||||
235
harness/tui-client.lisp
Normal file
235
harness/tui-client.lisp
Normal file
@@ -0,0 +1,235 @@
|
||||
(in-package :cl-user)
|
||||
(defpackage :opencortex.tui
|
||||
(:use :cl :croatoan)
|
||||
(:export :main))
|
||||
(in-package :opencortex.tui)
|
||||
|
||||
(defvar *daemon-host* "127.0.0.1")
|
||||
(defvar *daemon-port* 9105)
|
||||
(defvar *socket* nil)
|
||||
(defvar *stream* nil)
|
||||
(defvar *chat-history* (list))
|
||||
(defvar *status-text* "Connecting...")
|
||||
(defvar *input-buffer* (make-array 0 :element-type 'char :fill-pointer 0 :adjustable t))
|
||||
(defvar *command-history* (make-array 0 :element-type 't :fill-pointer 0 :adjustable t))
|
||||
(defvar *history-index* -1)
|
||||
(defvar *input-mode* :single) ; :single or :multi
|
||||
(defvar *is-running* t)
|
||||
(defvar *queue-lock* (bt:make-lock))
|
||||
(defvar *incoming-msgs* nil)
|
||||
|
||||
(defun enqueue-msg (msg)
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(push msg *incoming-msgs*)))
|
||||
|
||||
(defun add-to-history (cmd)
|
||||
"Add command to history, preserving most recent."
|
||||
(when (and cmd (> (length cmd) 0))
|
||||
;; Don't duplicate the last command
|
||||
(unless (and (> (length *command-history*) 0)
|
||||
(string= cmd (aref *command-history* (1- (length *command-history*))))))
|
||||
(vector-push-extend cmd *command-history* :adjustable t))
|
||||
(setf *history-index* (length *command-history*))))
|
||||
|
||||
(defun history-previous ()
|
||||
"Navigate to previous command in history."
|
||||
(when (> (length *command-history*) 0)
|
||||
(setf *history-index* (max 0 (1- *history-index*)))
|
||||
(let ((cmd (aref *command-history* *history-index*)))
|
||||
(setf (fill-pointer *input-buffer*) 0)
|
||||
(loop for ch across cmd do (vector-push-extend ch *input-buffer*))
|
||||
cmd)))
|
||||
|
||||
(defun history-next ()
|
||||
"Navigate to next command in history."
|
||||
(when (and *history-index* (< *history-index* (1- (length *command-history*))))
|
||||
(setf *history-index* (1+ *history-index*))
|
||||
(let ((cmd (aref *command-history* *history-index*)))
|
||||
(setf (fill-pointer *input-buffer*) 0)
|
||||
(loop for ch across cmd do (vector-push-extend ch *input-buffer*))
|
||||
cmd))
|
||||
(when (>= *history-index* (1- (length *command-history*)))
|
||||
(setf (fill-pointer *input-buffer*) 0)))
|
||||
|
||||
(defun dequeue-msgs ()
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(let ((msgs (nreverse *incoming-msgs*)))
|
||||
(setf *incoming-msgs* nil)
|
||||
msgs)))
|
||||
|
||||
(defun clean-keywords (msg)
|
||||
(if (listp msg)
|
||||
(let ((clean nil))
|
||||
(loop for (k v) on msg by #'cddr
|
||||
do (push (intern (string k) :keyword) clean)
|
||||
(push v clean))
|
||||
(nreverse clean))
|
||||
msg))
|
||||
|
||||
(defun format-payload (payload)
|
||||
"Extracts human-readable text from a protocol payload, handling nested tool calls."
|
||||
(let* ((action (getf payload :ACTION))
|
||||
(text (getf payload :TEXT))
|
||||
(msg (getf payload :MESSAGE))
|
||||
(tool (getf payload :TOOL))
|
||||
(prompt (getf payload :PROMPT))
|
||||
(args (getf payload :ARGS))
|
||||
(result (getf payload :RESULT)))
|
||||
(cond (text text)
|
||||
(msg msg)
|
||||
((eq action :MESSAGE) (getf payload :TEXT))
|
||||
((and tool prompt) (format nil "🤔 ~a: ~a" tool prompt))
|
||||
((and tool args)
|
||||
(let ((inner-prompt (or (getf args :PROMPT) (getf args :TEXT))))
|
||||
(if inner-prompt
|
||||
(format nil "🤔 ~a: ~a" tool inner-prompt)
|
||||
(format nil "🔧 ~a args: ~s" tool args))))
|
||||
(result (format nil "✅ ~a" result))
|
||||
(t (format nil "~s" payload)))))
|
||||
|
||||
(defun format-incoming (msg)
|
||||
"Formats incoming message with styling."
|
||||
(let ((type (or (getf msg :TYPE) (getf msg :type)))
|
||||
(payload (or (getf msg :PAYLOAD) (getf msg :payload))))
|
||||
(cond
|
||||
((and (listp msg) (eq type :EVENT))
|
||||
(let ((action (or (getf payload :ACTION) (getf payload :action)))
|
||||
(text (or (getf payload :TEXT) (getf payload :text) (getf payload :MESSAGE) (getf payload :message)))))
|
||||
(cond ((eq action :handshake) (format nil "👋 ~a" (or text "Connected")))
|
||||
((eq action :thinking) (format nil "🤔 ~a" (or text "Thinking...")))
|
||||
((eq action :tool-complete) (format nil "🔧 Done"))
|
||||
(text (format nil "💬 ~a" text))
|
||||
(t (format nil "📢 ~s" msg)))))
|
||||
((and (listp msg) (eq type :STATUS))
|
||||
(format nil "🔄 Scribe: ~a | Gardener: ~a"
|
||||
(or (getf msg :SCRIBE) "idle")
|
||||
(or (getf msg :GARDENER) "idle")))
|
||||
((and (listp msg) (member type '(:REQUEST :RESPONSE :LOG)))
|
||||
(format-payload payload))
|
||||
((and (listp msg) (eq type :EVENT) (eq (getf payload :SENSOR) :TOOL-OUTPUT))
|
||||
(format nil "🔧 ~a" (getf payload :RESULT)))
|
||||
(t (format nil "~s" msg))))
|
||||
|
||||
(defun listen-thread ()
|
||||
(loop while *is-running* do
|
||||
(handler-case
|
||||
(when (and *stream* (open-stream-p *stream*))
|
||||
(let ((raw-msg (opencortex:read-framed-message *stream*)))
|
||||
(unless (member raw-msg '(:eof :error))
|
||||
(let* ((msg (clean-keywords raw-msg))
|
||||
(type (or (getf msg :TYPE) (getf msg :type)))
|
||||
(payload (or (getf msg :PAYLOAD) (getf msg :payload))))
|
||||
(cond ((and (listp msg) (eq type :EVENT))
|
||||
(let ((action (or (getf payload :ACTION) (getf payload :action)))
|
||||
(text (or (getf payload :TEXT) (getf payload :text) (getf payload :MESSAGE) (getf payload :message))))
|
||||
(cond ((eq action :handshake) (setf *status-text* "Ready"))
|
||||
(text (enqueue-msg (format nil "SYSTEM: ~a" text))))))
|
||||
((and (listp msg) (eq type :STATUS))
|
||||
(setf *status-text* (format nil "[Scribe: ~a] [Gardener: ~a]"
|
||||
(or (getf msg :SCRIBE) (getf msg :scribe))
|
||||
(or (getf msg :GARDENER) (getf msg :gardener)))))
|
||||
((and (listp msg) (member type '(:REQUEST :RESPONSE :LOG)))
|
||||
(let ((formatted (format-payload payload)))
|
||||
(when formatted (enqueue-msg formatted))))
|
||||
((and (listp msg) (eq type :EVENT) (eq (getf payload :SENSOR) :TOOL-OUTPUT))
|
||||
(let ((formatted (format-payload payload)))
|
||||
(when formatted (enqueue-msg formatted))))
|
||||
(t (harness-log "TUI: Ignored unknown type ~a" type)))))
|
||||
(when (eq raw-msg :eof) (setf *is-running* nil))
|
||||
(when (eq raw-msg :error) (setf *status-text* "Protocol Error"))))
|
||||
(error (c) (setf *status-text* (format nil "Net Error: ~a" c)) (setf *is-running* nil)))
|
||||
(sleep 0.05)))
|
||||
|
||||
(defun main ()
|
||||
(handler-case
|
||||
(setf *socket* (usocket:socket-connect *daemon-host* *daemon-port*))
|
||||
(error (e) (format t "Error connecting: ~a~%" e) (return-from main)))
|
||||
(setf *stream* (usocket:socket-stream *socket*))
|
||||
(bt:make-thread #'listen-thread :name "tui-listener")
|
||||
|
||||
(unwind-protect
|
||||
(with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t :cursor-visible t :window-border-chars #\┌#\─#\┐#\│#\└#\┘#\─#\│)
|
||||
(let* ((h (height scr))
|
||||
(w (width scr))
|
||||
(chat-height (- h 5))
|
||||
(chat-win (make-instance 'window :height chat-height :width (- w 2) :position (list 1 1) :border t))
|
||||
(status-win (make-instance 'window :height 1 :width (- w 2) :position (list (- h 4) 1) :border t))
|
||||
(help-win (make-instance 'window :height 1 :width (- w 2) :position (list (- h 3) 1)))
|
||||
(input-win (make-instance 'window :height 1 :width (- w 2) :position (list (- h 2) 1) :border t))
|
||||
(last-status nil))
|
||||
|
||||
;; Draw help once
|
||||
(add-string help-win "↑↓ History | Esc Clear | /help /exit | Multi-line: Shift+Enter" :y 0 :x 0 :attributes '(:bold))
|
||||
(refresh help-win)
|
||||
|
||||
(setf (function-keys-enabled-p input-win) t)
|
||||
(setf (input-blocking input-win) nil)
|
||||
|
||||
(loop while *is-running* do
|
||||
;; 1. Handle incoming messages
|
||||
(let ((new-msgs (dequeue-msgs)))
|
||||
(when new-msgs
|
||||
(dolist (msg new-msgs)
|
||||
(let ((formatted (format-incoming msg)))
|
||||
(when formatted
|
||||
(push formatted *chat-history*)
|
||||
(setf *chat-history* (subseq *chat-history* 0 (min (length *chat-history*) 500))))))
|
||||
|
||||
(clear chat-win)
|
||||
(let ((line-num 1))
|
||||
(dolist (m (reverse (subseq *chat-history* 0 (min (length *chat-history*) (- chat-height 3)))))
|
||||
(add-string chat-win (format nil "│ ~a" m) :y line-num :x 1)
|
||||
(incf line-num)))
|
||||
;; Add border line count
|
||||
(add-string chat-win (format nil "├─ ~d messages" (length *chat-history*)) :y (1- chat-height) :x 1 :attributes '(:dim))
|
||||
(refresh chat-win)))
|
||||
|
||||
;; 2. Render Status Bar ONLY if changed
|
||||
(unless (equal *status-text* last-status)
|
||||
(clear status-win)
|
||||
(add-string status-win (format nil "┤ ~a ┤" *status-text*) :y 0 :x 1 :attributes '(:reverse))
|
||||
(refresh status-win)
|
||||
(setf last-status *status-text*))
|
||||
|
||||
;; 3. Handle Keyboard Input
|
||||
(let* ((event (get-wide-event input-win))
|
||||
(ch (and event (typep event 'event) (event-key event))))
|
||||
(when ch
|
||||
(cond
|
||||
((or (eq ch #\Newline) (eq ch #\Return))
|
||||
(let ((cmd (coerce *input-buffer* 'string)))
|
||||
(setf (fill-pointer *input-buffer*) 0)
|
||||
(when (> (length cmd) 0)
|
||||
(add-to-history cmd)
|
||||
(enqueue-msg (format nil "⬆ ~a" cmd))
|
||||
(let ((framed (opencortex:frame-message (list :TYPE :EVENT
|
||||
:META (list :SOURCE :tui :SESSION-ID "default")
|
||||
:PAYLOAD (list :SENSOR :user-input :TEXT cmd)))))
|
||||
(format *stream* "~a" framed)
|
||||
(finish-output *stream*)))
|
||||
(when (string= cmd "/exit") (setf *is-running* nil))
|
||||
(when (string= cmd "/clear") (setf *chat-history* nil))
|
||||
(when (string= cmd "/help")
|
||||
(enqueue-msg "Available commands: /help /exit /clear /status")
|
||||
(enqueue-msg "Use ↑↓ for history, Esc to clear input"))))
|
||||
((eq ch :up) (history-previous))
|
||||
((eq ch :down) (history-next))
|
||||
((eq ch :escape)
|
||||
(setf (fill-pointer *input-buffer*) 0)
|
||||
(setf *history-index* (length *command-history*)))
|
||||
((or (eq ch :backspace) (eq ch #\Backspace) (eq ch #\Rubout) (eq ch #\Del))
|
||||
(when (> (fill-pointer *input-buffer*) 0)
|
||||
(decf (fill-pointer *input-buffer*))))
|
||||
((eq ch :shift-left) ; Shift+Enter for multi-line
|
||||
(vector-push-extend #\Newline *input-buffer*))
|
||||
((characterp ch)
|
||||
(vector-push-extend ch *input-buffer*))))
|
||||
|
||||
(clear input-win)
|
||||
(let ((prompt (if (> (fill-pointer *input-buffer*) 0) "│" "▶")))
|
||||
(add-string input-win (format nil "~a ~a" prompt (coerce *input-buffer* 'string)) :y 0 :x 1 :attributes (when (> (fill-pointer *input-buffer*) 0) '(:bold))))
|
||||
(refresh input-win))
|
||||
|
||||
(sleep 0.02))))
|
||||
(setf *is-running* nil)
|
||||
(when *socket* (usocket:socket-close *socket*))))
|
||||
@@ -10,7 +10,7 @@
|
||||
The OpenCortex TUI Client is a standalone Common Lisp application built on **Croatoan**. It provides a real-time, multi-window interface for interacting with the OpenCortex daemon.
|
||||
|
||||
* Implementation
|
||||
#+begin_src lisp :tangle ../library/tui-client.lisp
|
||||
#+begin_src lisp :tangle ./tui-client.lisp
|
||||
(in-package :cl-user)
|
||||
(defpackage :opencortex.tui
|
||||
(:use :cl :croatoan)
|
||||
|
||||
Reference in New Issue
Block a user