amr/passepartout
1
0
Fork 0
Code Issues 15 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

feat(core): Skills consolidation and v0.2.0 TUI integration

Browse Source 
- NEW: org-skill-utils-lisp (consolidated from org-skill-lisp-utils)
  * 3-phase validation: structural, syntactic, semantic
  * Sandboxed eval, AST extraction/injection/wrapping
  * Format, list-definitions utilities

- NEW: org-skill-utils-org (consolidated from org-skill-emacs-edit)
  * Read/update/delete org headlines
  * Property management, TODO state handling
  * ID-link and internal link support

- DELETE: org-skill-lisp-utils (merged into utils-lisp)
- DELETE: org-skill-emacs-edit (merged into utils-org)
- RENAME: run-all-tests.lisp -> run-tests.lisp

- HARDEN: Skill loader with improved lisp keyword handling
- FIX: Package jailing issues with def-cognitive-tool macro conflicts
- ADD: Setup wizard (opencortex setup) and doctor (opencortex doctor)
- ADD: TUI client with Croatoan for native terminal rendering

- REMOVE: Dynamic loading from opencortex.asd (use :force t instead)
- CLEANUP: Test file consolidation (removed duplicate test suites)

Co-authored-by: Agent <agent@memex>
This commit is contained in:
Amr Gharbeia
2026-04-30 10:52:20 -04:00
parent c0d3f066e8
commit 6a6f4479ac
95 changed files with 2069 additions and 4552 deletions
Download Patch File Download Diff File Expand all files Collapse all files

262
harness/act.lisp
View File

@@ -1,156 +1,66 @@
(in-package :opencortex)
(defvar *default-actuator* :cli
"The actuator used when no explicit target is specified.
Override with DEFAULT_ACTUATOR environment variable.")
"The actuator used when no explicit target is specified.")
(defvar *silent-actuators* '(:cli :system-message :emacs)
"List of actuators that don't generate tool-output feedback.
These typically have their own feedback mechanisms (CLI prints directly, etc.)")
"List of actuators that don't generate tool-output feedback.")
(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
"Register core actuators and load 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
(setf *default-actuator* (intern (string-upcase def) :keyword)))
(when silent
(setf *silent-actuators*
(mapcar (lambda (s)
(intern (string-upcase (string-trim '(#\Space) s))
"KEYWORD"))
(str:split "," silent)))))
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword))
(uiop:split-string silent :separator '(#\,))))))
;; 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))
(declare (ignore context))
(let* ((meta (getf action :meta))
(stream (getf meta :reply-stream)))
(when (and stream (open-stream-p stream))
(format stream "~a" (frame-message action))
(finish-output stream))))))
(defun dispatch-action (action context)
"Route an approved action to its registered actuator.
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)."
"Route an approved action to its registered actuator."
(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*))
(raw-target (or (proto-get 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))))))
(harness-log "ACT ERROR: No actuator registered for '~s'" 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."
"Execute internal harness commands."
(declare (ignore context))
(let* ((payload (ignore-errors (getf action :payload)))
(cmd (ignore-errors (getf payload :action))))
(let* ((payload (getf action :payload))
(cmd (getf payload :action)))
(case cmd
;; Evaluate Lisp code - guarded by lisp-utils 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
(eval (read-from-string (getf payload :code))))
(: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."
"Execute a registered cognitive tool."
(let* ((payload (getf action :payload))
(tool-name (getf payload :tool))
(tool-args (getf payload :args))
@@ -158,156 +68,66 @@
(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))
(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
(dispatch-action (list :TYPE :REQUEST :TARGET source
:PAYLOAD (list :ACTION :MESSAGE :TEXT (format-tool-result tool-name result)))
context))
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
:PAYLOAD (list :SENSOR :tool-output :RESULT result :TOOL tool-name)))
(error (c)
(list :TYPE :EVENT
:DEPTH (1+ depth)
:META meta
:PAYLOAD (list :SENSOR :tool-error
:TOOL tool-name
:MESSAGE (format nil "~a" c)))))
;; 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))))))
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
:PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c)))))
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
:PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name))))))
(defun format-tool-result (tool-name result)
"Format a tool result for 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."
"Format a tool result for display."
(if (listp result)
(let ((status (getf result :status))
(content (getf result :content))
(msg (getf result :message)))
(cond
((and (eq status :success) content)
(format nil "~a" content))
((and (eq status :error) msg)
(format nil "ERROR [~a]: ~a" tool-name msg))
(t
(format nil "TOOL [~a] RESULT: ~s" tool-name result))))
((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."
"Final stage of the metabolic pipeline: Actuation."
(let* ((approved (getf signal :approved-action))
(type (getf signal :type))
(meta (getf signal :meta))
(source (getf meta :source))
(feedback nil)
(context signal))
;; Step 1: Last-mile deterministic verification
;; This catches any issues that arose between reasoning and acting
(feedback nil))
(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
(if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) (not (member original-type '(:LOG :EVENT))))
(progn
(harness-log "ACT BLOCKED: Action failed last-mile deterministic check.")
(setf (getf signal :approved-action) nil)
(setf 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
(:REQUEST (dispatch-action signal signal))
(:LOG (dispatch-action signal signal))
(:EVENT
(if approved
(let* ((target (getf approved :target))
(result (dispatch-action approved context)))
;; Determine feedback based on actuator response
(result (dispatch-action approved signal)))
(cond
;; Actuator returned a signal - use it as feedback
((and (listp result)
(member (getf result :type) '(:EVENT :LOG)))
((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
((and result (not (member target *silent-actuators*)))
(setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta
:payload (list :sensor :tool-output :result result :tool approved))))))
(when source (dispatch-action signal signal)))))
(setf (getf signal :status) :acted)
feedback))

43
harness/communication-validator.lisp
View File

@@ -1,44 +1,9 @@
(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))))
"Strict structural validation for incoming protocol messages."
(unless (listp msg) (error "Message must be a plist"))
(let ((type (proto-get msg :type)))
(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"))))
(error "Invalid message type '~a'" type))
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))

121
harness/communication.lisp
View File

@@ -1,14 +1,5 @@
(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.")
@@ -17,48 +8,6 @@
(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))
@@ -76,3 +25,73 @@
(payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized)))
(len (length payload)))
(format nil "~6,'0x~a" len payload)))
(defun read-framed-message (stream)
"Reads a hex-length prefixed S-expression from the stream securely."
(let ((length-buffer (make-string 6)))
(handler-case
(progn
(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))
(let ((count (read-sequence length-buffer stream)))
(if (< count 6)
:eof
(let ((len (ignore-errors (parse-integer length-buffer :radix 16))))
(if (not len)
:error
(let ((msg-buffer (make-string len)))
(read-sequence msg-buffer stream)
(let ((*read-eval* nil))
(handler-case (read-from-string msg-buffer)
(error () :error)))))))))
(error () :error))))
(defvar *server-socket* nil)
(defun handle-client-connection (socket)
"Handles a single TUI/CLI client connection in a dedicated thread."
(let ((stream (usocket:socket-stream socket)))
(handler-case
(progn
(format stream "~a" (frame-message (make-hello-message "0.2.0")))
(finish-output stream)
(loop
(let ((msg (read-framed-message stream)))
(cond
((eq msg :eof) (return))
((eq msg :error) (return))
((eq (getf msg :type) :health-check)
;; Handle health check request
(let ((health-msg (list :type :health-response
:status (or (and (boundp 'opencortex::*system-health*)
(symbol-value 'opencortex::*system-health*))
:unknown)
:checked-p (or (and (boundp 'opencortex::*health-check-ran*)
(symbol-value 'opencortex::*health-check-ran*))
nil))))
(format stream "~a" (frame-message health-msg))
(finish-output stream)))
(t (inject-stimulus msg :stream stream))))))
(error (c) (harness-log "CLIENT ERROR: ~a" c)))
(ignore-errors (usocket:socket-close socket))))
(defun start-daemon (&key (port 9105))
"Starts the network listener for TUI/CLI clients."
(setf *server-socket* (usocket:socket-listen "127.0.0.1" port :reuse-address t))
(harness-log "DAEMON: Listening on localhost:~a" port)
(bt:make-thread
(lambda ()
(loop
(let ((client-socket (usocket:socket-accept *server-socket*)))
(when client-socket
(bt:make-thread (lambda () (handle-client-connection client-socket))
:name "opencortex-client-handler")))))
:name "opencortex-server-listener"))
(defun make-hello-message (version)
"Constructs the standard HELLO handshake message."
(list :TYPE :EVENT
:PAYLOAD (list :ACTION :handshake
:VERSION version
:CAPABILITIES '(:AUTH :ORG-AST))))

9
harness/context.lisp
View File

@@ -60,9 +60,6 @@
(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 ""))
@@ -72,15 +69,12 @@
(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
@@ -109,8 +103,7 @@
(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):
"))
(output (format nil "GLOBAL MEMEX AWARENESS (Peripheral Vision):~%")))
(if projects
(dolist (project projects)
(setf output (concatenate 'string output

1
harness/doctor.lisp
View File

@@ -64,6 +64,7 @@
(let ((dep-ok (doctor-check-dependencies))
(env-ok (doctor-check-env))
(llm-ok (doctor-check-llm)))
(declare (ignore llm-ok))
(harness-log "==================================================")
(if (and dep-ok env-ok)
(progn

78
harness/doctor.org
View File

@@ -24,65 +24,58 @@ Common Lisp's `getenv` is strictly typed in SBCL. The Doctor must ensure that mi
* Phase B: Protocol (Success Criteria)
** Package Context
#+begin_src lisp :tangle doctor.lisp (concat (concat (or (getenv "INSTALL_DIR ". "/harness "/tests)
#+begin_src lisp :tangle ../tests/doctor-tests.lisp
(defpackage :opencortex-doctor-tests
(:use :cl :fiveam :opencortex)
(:export #:doctor-suite))
#+end_src
#+begin_src lisp :tangle doctor.lisp (concat (concat (or (getenv "INSTALL_DIR ". "/harness "/tests)
(in-package :opencortex-doctor-tests)
#+end_src
#+begin_src lisp :tangle doctor.lisp (concat (concat (or (getenv "INSTALL_DIR ". "/harness "/tests)
(def-suite doctor-suite :description "Verification of the System Doctor diagnostic logic
#+end_src
#+begin_src lisp :tangle doctor.lisp (concat (concat (or (getenv "INSTALL_DIR ". "/harness "/tests)
(def-suite doctor-suite :description "Verification of the System Doctor diagnostic logic")
(in-suite doctor-suite)
#+end_src
** Dependency Tests
#+begin_src lisp :tangle doctor.lisp (concat (concat (or (getenv "INSTALL_DIR ". "/harness "/tests)
#+begin_src lisp :tangle ../tests/doctor-tests.lisp
(test test-dependency-check-fail
"Verify that missing binaries are correctly identified as failures."
(let ((opencortex::*doctor-required-binaries* '("non-existent-binary-123))
(let ((opencortex::*doctor-required-binaries* '("non-existent-binary-123")))
(is (null (opencortex:doctor-check-dependencies)))))
#+end_src
** Environment Tests
#+begin_src lisp :tangle doctor.lisp (concat (concat (or (getenv "INSTALL_DIR ". "/harness "/tests)
#+begin_src lisp :tangle ../tests/doctor-tests.lisp
(test test-env-validation-fail
"Verify that an invalid MEMEX_DIR triggers a critical failure."
(let ((old-m (getenv "MEMEX_DIR)
(old-s (getenv "SKILLS_DIR))
(let ((old-m (uiop:getenv "MEMEX_DIR"))
(old-s (uiop:getenv "SKILLS_DIR")))
(unwind-protect
(progn
(setf (getenv "MEMEX_DIR "/non/existent/path/999
(setf (uiop:getenv "MEMEX_DIR") "/non/existent/path/999")
(is (null (opencortex:doctor-check-env))))
(setf (getenv "MEMEX_DIR (or old-m
(setf (getenv "SKILLS_DIR (or old-s )))
(setf (uiop:getenv "MEMEX_DIR") (or old-m ""))
(setf (uiop:getenv "SKILLS_DIR") (or old-s "")))))
#+end_src
* Phase C: Implementation (Build)
** Package Context
#+begin_src lisp :tangle doctor.lisp )
#+begin_src lisp
(in-package :opencortex)
#+end_src
** Global Configuration
#+begin_src lisp :tangle doctor.lisp )
(defvar *doctor-required-binaries* '("sbcl" "emacs" "git" "socat" "nc
"List of external binaries required for full system operation.
#+begin_src lisp
(defvar *doctor-required-binaries* '("sbcl" "emacs" "git" "socat" "nc")
"List of external binaries required for full system operation.")
#+end_src
** Dependency Verification
#+begin_src lisp :tangle doctor.lisp )
#+begin_src lisp
(defun doctor-check-dependencies ()
"Verifies that required external binaries are available in the PATH via a shell probe."
(let ((all-ok t))
(harness-log "DOCTOR: Checking system dependencies...
(harness-log "DOCTOR: Checking system dependencies...")
(dolist (dep *doctor-required-binaries*)
(let ((path (ignore-errors
(uiop:run-program (list "which" dep)
@@ -96,15 +89,15 @@ Common Lisp's `getenv` is strictly typed in SBCL. The Doctor must ensure that mi
#+end_src
** Environment & XDG Validation
#+begin_src lisp :tangle doctor.lisp )
#+begin_src lisp
(defun doctor-check-env ()
"Validates XDG directories and environment configuration against the POSIX standard."
(harness-log "DOCTOR: Checking XDG environment...
(harness-log "DOCTOR: Checking XDG environment...")
(let ((all-ok t)
(config-dir (getenv "OC_CONFIG_DIR)
(data-dir (getenv "OC_DATA_DIR)
(state-dir (getenv "OC_STATE_DIR)
(memex-dir (getenv "MEMEX_DIR))
(config-dir (uiop:getenv "OC_CONFIG_DIR"))
(data-dir (uiop:getenv "OC_DATA_DIR"))
(state-dir (uiop:getenv "OC_STATE_DIR"))
(memex-dir (uiop:getenv "MEMEX_DIR")))
(flet ((check-dir (name path critical)
(if (and path (> (length path) 0))
@@ -125,42 +118,43 @@ Common Lisp's `getenv` is strictly typed in SBCL. The Doctor must ensure that mi
#+end_src
** LLM Connectivity
#+begin_src lisp :tangle doctor.lisp )
#+begin_src lisp
(defun doctor-check-llm ()
"Tests connectivity to primary LLM providers. Non-critical fallback allowed."
(harness-log "DOCTOR: Checking LLM connectivity...
(let ((openrouter-key (getenv "OPENROUTER_API_KEY))
(harness-log "DOCTOR: Checking LLM connectivity...")
(let ((openrouter-key (uiop:getenv "OPENROUTER_API_KEY")))
(if (and openrouter-key (> (length openrouter-key) 0))
(progn
(harness-log " [OK] OpenRouter API Key detected.
(harness-log " [OK] OpenRouter API Key detected.")
t)
(progn
(harness-log " [WARN] No OpenRouter API Key. Falling back to local inference only.
(harness-log " [WARN] No OpenRouter API Key. Falling back to local inference only.")
t))))
#+end_src
** Orchestration
#+begin_src lisp :tangle doctor.lisp )
#+begin_src lisp
(defun doctor-run-all ()
"Executes the full diagnostic suite and returns T if system is healthy."
(harness-log "==================================================
(harness-log " OPENCORTEX DOCTOR: Commencing Health Check
(harness-log "==================================================
(harness-log "==================================================")
(harness-log " OPENCORTEX DOCTOR: Commencing Health Check")
(harness-log "==================================================")
(let ((dep-ok (doctor-check-dependencies))
(env-ok (doctor-check-env))
(llm-ok (doctor-check-llm)))
(harness-log "==================================================
(declare (ignore llm-ok))
(harness-log "==================================================")
(if (and dep-ok env-ok)
(progn
(harness-log " ✓ SYSTEM HEALTHY: Ready for ignition.
(harness-log " ✓ SYSTEM HEALTHY: Ready for ignition.")
t)
(progn
(harness-log " ✗ SYSTEM UNHEALTHY: Fix the errors above.
(harness-log " ✗ SYSTEM UNHEALTHY: Fix the errors above.")
nil))))
#+end_src
** CLI Entry Point
#+begin_src lisp :tangle doctor.lisp )
#+begin_src lisp
(defun doctor-main ()
"Entry point for the 'doctor' CLI command."
(if (doctor-run-all)

173
harness/loop.lisp
View File

@@ -1,108 +1,55 @@
(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.")
"Atomic flag set by signal handlers to trigger graceful shutdown.")
(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.")
"Mutex protecting *interrupt-flag* access.")
(defvar *heartbeat-thread* nil
"Handle to the heartbeat thread, allowing explicit termination on shutdown.")
"Handle to the heartbeat thread.")
(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."
"The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act."
(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))
(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)))))))))))
(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.")
(defvar *auto-save-interval* 300)
(defvar *heartbeat-save-counter* 0)
(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)"
"Starts the background heartbeat thread."
(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)
@@ -112,82 +59,78 @@
(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)))))
(list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
:name "opencortex-heartbeat"))))
:name "opencortex-heartbeat")))))
(defvar *shutdown-save-enabled* t)
(defvar *shutdown-save-enabled* t
"When T, save memory to disk on graceful shutdown.
Disable for testing or when memory persistence is handled externally.")
(defvar *system-health* :unknown
"Current system health status: :healthy, :degraded, :unhealthy, or :unknown.")
(defvar *health-check-ran* nil
"Flag indicating if initial health check has completed.")
(defun run-startup-health-check ()
"Runs the doctor diagnostics on startup. Returns health status."
(format t "~%")
(format t "==================================================~%")
(format t " DOCTOR: Running Startup Health Check~%")
(format t "==================================================~%")
(handler-case
(progn
(when (fboundp 'doctor-run-all)
(let ((result (doctor-run-all :auto-install nil)))
(setf *health-check-ran* t)
(if result
(progn
(setf *system-health* :healthy)
(format t "DAEMON: Health check passed. Starting services.~%"))
(progn
(setf *system-health* :degraded)
(format t "DAEMON: Health check found issues.~%")
(format t " Run 'opencortex doctor --fix' to repair.~%")))))
(setf *health-check-ran* t))
(error (c)
(format t "DOCTOR ERROR: ~a~%" c)
(setf *system-health* :unhealthy)
(setf *health-check-ran* t)))
(format t "==================================================~%~%"))
(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
"Entry point for OpenCortex. Initializes the system and enters idle loop."
(let* ((home (uiop:getenv "HOME"))
(env-file (uiop:merge-pathnames*
".local/share/opencortex/.env"
(uiop:ensure-directory-pathname 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
;; Run proactive doctor before starting services
(run-startup-health-check)
(start-heartbeat)
(start-daemon)
;; 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)))
(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)))
(let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600)))
(loop
;; Check for interrupt before each sleep cycle
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
(harness-log "SHUTDOWN: Interrupt flag set. Saving memory...")
(when *shutdown-save-enabled*
(save-memory-to-disk))
(when *shutdown-save-enabled* (save-memory-to-disk))
(return))
;; Sleep in configured intervals (default: 1 hour)
(sleep sleep-interval))))

93
harness/manifest.org
View File

@@ -2,7 +2,7 @@
#+AUTHOR: Agent
#+FILETAGS: :harness:manifest:
#+STARTUP: content
#+PROPERTY: header-args:lisp :tangle opencortex.asd
#+PROPERTY: header-args:lisp :tangle ../opencortex.asd
* Overview
The *System Manifest* defines the structural components of the OpenCortex.
@@ -19,79 +19,46 @@ The *System Manifest* defines the structural components of the OpenCortex.
:description "The Probabilistic-Deterministic Lisp Machine"
:depends-on (:usocket :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str :cl-json :uuid)
:serial t
:components ((:file "harness/package
(:file "harness/skills
(:file "harness/communication
(:file "harness/communication-validator
(:file "harness/memory
(:file "harness/context
(:file "harness/perceive
(:file "harness/reason
(:file "harness/act
(:file "harness/loop))
:components ((:file "harness/package")
(:file "harness/skills")
(:file "harness/communication")
(:file "harness/communication-validator")
(:file "harness/memory")
(:file "harness/context")
(:file "harness/perceive")
(:file "harness/reason")
(:file "harness/act")
(:file "harness/loop")))
#+end_src
** Test System
#+begin_src lisp
(defsystem :opencortex/tests
:depends-on (:opencortex :fiveam)
:components ((:file "tests/pipeline-act-tests
(:file "tests/boot-sequence-tests
(:file "tests/immune-system-tests
(:file "tests/memory-tests
(:file "tests/pipeline-perceive-tests
(:file "tests/pipeline-reason-tests
(:file "tests/peripheral-vision-tests
(:file "tests/emacs-edit-tests
(:file "tests/engineering-standards-tests
(:file "tests/lisp-utils-tests
(:file "tests/literate-programming-tests
(:file "tests/self-edit-tests
(:file "tests/tool-permissions-tests
(:file "tests/diagnostics-tests
(:file "tests/config-manager-tests
(:file "tests/gateway-manager-tests
(:file "tests/tui-tests
(:file "tests/llm-gateway-tests))
:components ((:file "tests/pipeline-act-tests")
(:file "tests/boot-sequence-tests")
(:file "tests/immune-system-tests")
(:file "tests/memory-tests")
(:file "tests/pipeline-perceive-tests")
(:file "tests/pipeline-reason-tests")
(:file "tests/peripheral-vision-tests")
(:file "tests/utils-org-tests")
(:file "tests/engineering-standards-tests")
(:file "tests/utils-lisp-tests")
(:file "tests/literate-programming-tests")
(:file "tests/self-edit-tests")
(:file "tests/tool-permissions-tests")
(:file "tests/diagnostics-tests")
(:file "tests/config-manager-tests")
(:file "tests/gateway-manager-tests")
(:file "tests/tui-tests")
(:file "tests/llm-gateway-tests")))
#+end_src
** TUI System
#+begin_src lisp
(defsystem :opencortex/tui
:depends-on (:opencortex :croatoan :usocket :bordeaux-threads)
:components ((:file "harness/tui-client))
:components ((:file "harness/tui-client")))
#+end_src
** Test Orchestrator
#+begin_src lisp :tangle opencortex.asd
(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))
(let ((oc-dir (or (uiop:getenv "OC_DATA_DIR
(namestring (truename "./))))
(push (uiop:ensure-directory-pathname oc-dir) asdf:*central-registry*))
(ql:quickload '(:fiveam :opencortex :opencortex/tui :opencortex/tests) :silent t)
(format t "~%=== Initializing Skills BEFORE loading tests ===~%
(opencortex:initialize-all-skills)
(format t "~%=== Running ALL Test Suites ===~%
(dolist (suite-spec '(("OPENCORTEX-BOOT-TESTS" "BOOT-SUITE
("OPENCORTEX-COMMUNICATION-TESTS" "COMMUNICATION-PROTOCOL-SUITE
("OPENCORTEX-PIPELINE-ACT-TESTS" "PIPELINE-ACT-SUITE
("OPENCORTEX-MEMORY-TESTS" "MEMORY-SUITE
("OPENCORTEX-ENGINEERING-STANDARDS-TESTS" "ENGINEERING-STANDARDS-SUITE
("OPENCORTEX-DIAGNOSTICS-TESTS" "DIAGNOSTICS-SUITE
("OPENCORTEX-GATEWAY-MANAGER-TESTS" "GATEWAY-SUITE
("OPENCORTEX-TUI-TESTS" "TUI-SUITE
("OPENCORTEX-LLM-GATEWAY-TESTS" "LLM-GATEWAY-SUITE))
(let ((pkg (find-package (first suite-spec))))
(when pkg
(let ((suite-sym (find-symbol (second suite-spec) pkg)))
(when suite-sym
(format t "~&--- Suite: ~A ---~%" (first suite-spec))
(fiveam:run! suite-sym))))))
(format t "~%=== ALL TESTS COMPLETE ===~%
#+end_src

183
harness/memory.lisp
View File

@@ -1,19 +1,28 @@
(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 copy-org-object (obj)
(make-org-object :id (org-object-id obj)
:type (org-object-type obj)
:attributes (copy-list (org-object-attributes obj))
:content (org-object-content obj)
:vector (org-object-vector obj)
:parent-id (org-object-parent-id obj)
:children (copy-list (org-object-children obj))
:version (org-object-version obj)
:last-sync (org-object-last-sync obj)
:hash (org-object-hash obj)))
(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))
@@ -25,23 +34,19 @@
(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))
(format nil "~a~%~a" (getf props :TITLE) (or (getf ast :raw-content) ""))))
(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)))))))
(let ((child-obj (gethash child-id *memory*)))
(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))
@@ -49,194 +54,64 @@
(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))
(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*)))
(let ((snapshot (make-hash-table :test 'equal :size (hash-table-size *memory*))))
(maphash (lambda (k v) (setf (gethash k snapshot) (copy-org-object v))) *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)))
(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))))
(defvar *memory-snapshot-path* nil
"Path to the memory snapshot file. Set from MEMORY_SNAPSHOT_PATH env or default.")
(defvar *memory-snapshot-path* nil)
(defun ensure-memory-snapshot-path ()
"Initializes the snapshot path from environment or default location."
(or *memory-snapshot-path*
(let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH")))
(setf *memory-snapshot-path*
(or env-path
(uiop:merge-pathnames* "memory.snap" (user-homedir-pathname)))))))
(or env-path (namestring (uiop:merge-pathnames* "memory.snap" (user-homedir-pathname))))))))
(defun save-memory-to-disk ()
"Serializes *memory* and *history-store* to disk for crash recovery.
Converts hash tables to alists for proper serialization."
(let ((path (ensure-memory-snapshot-path)))
(with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create)
(format stream ";; OpenCortex Memory Snapshot~%")
(format stream ";; Created: ~a~%~%" (format nil "~a" (get-universal-time)))
(let ((memory-alist nil)
(history-alist nil))
(let ((memory-alist nil) (history-alist nil))
(maphash (lambda (k v) (push (cons k v) memory-alist)) *memory*)
(maphash (lambda (k v) (push (cons k v) history-alist)) *history-store*)
(prin1 (list :memory memory-alist :history-store history-alist) stream)))
(harness-log "MEMORY - Saved to ~a" path)
path))
(harness-log "MEMORY - Saved to ~a" path)))
(defun load-memory-from-disk ()
"Loads *memory* and *history-store* from disk if the snapshot exists.
Reconstitutes alists into hash tables."
(let ((path (ensure-memory-snapshot-path)))
(when (uiop:file-exists-p path)
(handler-case
(with-open-file (stream path :direction :input)
(let ((data (read stream nil)))
(when data
(let ((memory-alist (getf data :memory))
(history-alist (getf data :history-store)))
(let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store)))
(setf *memory* (make-hash-table :test 'equal :size (length memory-alist)))
(dolist (kv memory-alist)
(setf (gethash (car kv) *memory*) (cdr kv)))
(dolist (kv memory-alist) (setf (gethash (car kv) *memory*) (cdr kv)))
(setf *history-store* (make-hash-table :test 'equal :size (length history-alist)))
(dolist (kv history-alist)
(setf (gethash (car kv) *history-store*) (cdr kv)))
(dolist (kv history-alist) (setf (gethash (car kv) *history-store*) (cdr kv)))
(harness-log "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory*))))))
(error (c)
(harness-log "MEMORY WARNING - Failed to load snapshot: ~a" c))))
t))
(defvar *embedding-cache* (make-hash-table :test 'equal)
"Cache for embeddings to avoid redundant API calls.")
(defun get-embedding (text)
"Generates a vector embedding for the given text via Ollama. Returns nil on failure."
(when (or (null text) (string= text ""))
(return-from get-embedding nil))
(let ((cached (gethash text *embedding-cache*)))
(when cached (return-from get-embedding cached)))
(let ((result (funcall (get-cognitive-tool-body :get-ollama-embedding) (list :text text))))
(when (eq (getf result :status) :success)
(let ((vec (getf result :vector)))
(setf (gethash text *embedding-cache*) vec)
vec))))
(defun cosine-similarity (vec-a vec-b)
"Computes cosine similarity between two vectors. Both should be sequences of numbers."
(when (or (null vec-a) (null vec-b) (zerop (length vec-a)) (zerop (length vec-b)))
(return-from cosine-similarity 0.0))
(let ((dot-product (loop for a across vec-a
for b across vec-b
sum (* a b)))
(norm-a (sqrt (loop for a across vec-a sum (* a a))))
(norm-b (sqrt (loop for b across vec-b sum (* b b)))))
(if (or (zerop norm-a) (zerop norm-b))
0.0
(/ dot-product (* norm-a norm-b)))))
(defun semantic-search (query &key (limit 10) (min-similarity 0.5))
"Searches memory for objects semantically similar to the query.
Returns up to LIMIT objects with similarity >= MIN-SIMILARITY, sorted by similarity descending."
(let* ((query-vec (get-embedding query))
(results nil))
(unless query-vec
(harness-log "EMBEDDING: Failed to generate embedding for query: ~a" query)
(return-from semantic-search nil))
(maphash (lambda (id obj)
(let ((obj-vec (org-object-vector obj)))
(when obj-vec
(let ((sim (cosine-similarity query-vec obj-vec)))
(when (>= sim min-similarity)
(push (list :id id :object obj :similarity sim) results))))))
*memory*)
(setf results (sort results #'> :key (lambda (r) (getf r :similarity))))
(subseq results 0 (min limit (length results)))))
(def-cognitive-tool :semantic-search
"Searches memory for objects semantically similar to a query."
((:query :type :string :description "The search query.")
(:limit :type :integer :description "Maximum results to return." :default 10)
(:min-similarity :type :number :description "Minimum similarity threshold (0-1)." :default 0.5))
:body (lambda (args)
(semantic-search (getf args :query)
:limit (or (getf args :limit) 10)
:min-similarity (or (getf args :min-similarity) 0.5))))
(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)))
(if (not (and texts (listp texts)))
(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)))))))
(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)))
(error (c) (harness-log "MEMORY WARNING - Failed to load snapshot: ~a" c)))))
t)

72
harness/package.lisp
View File

@@ -35,10 +35,6 @@
#:skill-gateway-link
#:gateway-manager-main
;; --- Diagnostic Doctor ---
#:doctor-run-all
#:doctor-main
;; --- Memory (CLOSOS) ---
#:ingest-ast
#:lookup-object
@@ -109,44 +105,45 @@
;; --- Engineering Standards Skill ---
#:verify-git-clean-p
#:engineering-standards-verify-lisp
#:engineering-standards-format-lisp
;; --- Literate Programming Skill ---
#:literate-check-block-balance
#:check-tangle-sync
#:*tangle-targets*
;; --- Emacs Edit Skill ---
#:emacs-edit-read-file
#:emacs-edit-write-file
#:emacs-edit-add-headline
#:emacs-edit-set-property
#:emacs-edit-set-todo
#:emacs-edit-find-headline-by-id
#:emacs-edit-find-headline-by-title
#:emacs-edit-generate-id
#:emacs-edit-id-format
#:emacs-edit-ast-to-org
#:emacs-edit-modify
;; --- Utils Org Skill ---
#:utils-org-read-file
#:utils-org-write-file
#:utils-org-add-headline
#:utils-org-set-property
#:utils-org-set-todo
#:utils-org-find-headline-by-id
#:utils-org-find-headline-by-title
#:utils-org-generate-id
#:utils-org-id-format
#:utils-org-ast-to-org
#:utils-org-modify
;; --- Lisp Utils Skill ---
#:lisp-utils-validate
#:lisp-utils-check-structural
#:lisp-utils-check-syntactic
#:lisp-utils-check-semantic
#:lisp-utils-register
;; --- Utils Lisp Skill ---
#:utils-lisp-validate
#:utils-lisp-check-structural
#:utils-lisp-check-syntactic
#:utils-lisp-check-semantic
#:utils-lisp-eval
#:utils-lisp-format
#:utils-lisp-list-definitions
#:utils-lisp-structural-extract
#:utils-lisp-structural-wrap
#:utils-lisp-structural-inject
#:utils-lisp-structural-slurp
#:utils-lisp-register
;; --- Config Manager & Diagnostics Skill ---
#:register-provider
#:save-providers
#:configure-provider
#:run-setup-wizard
#:get-oc-config-dir
#:prompt-for
#:save-secret
#:doctor-check-dependencies
#:doctor-check-xdg
#:doctor-check-llm
#:doctor-run-all
;; --- Tool Permissions Skill ---
#:get-tool-permission
@@ -238,3 +235,18 @@
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
(format t "~a~%" formatted-msg)
(finish-output)))
;; --- Debugger Hook ---
(setf *debugger-hook* (lambda (condition hook)
"Friendly error handler - shows diagnostic message instead of raw debugger."
(format t "~%")
(format t "┌─────────────────────────────────────────────┐~%")
(format t "│ ERROR: ~A~%" (type-of condition))
(format t "│~%")
(format t "│ Run: opencortex doctor~%")
(format t "│ For system diagnostics~%")
(format t "└─────────────────────────────────────────────┘~%")
(format t "~%")
(format t "Details: ~A~%" condition)
(finish-output)
(uiop:quit 1)))

60
harness/package.org
View File

@@ -118,31 +118,40 @@ The ~package.lisp~ file defines the public API of the ~opencortex~ harness.
;; --- Engineering Standards Skill ---
#:verify-git-clean-p
#:engineering-standards-verify-lisp
#:engineering-standards-format-lisp
;; --- Literate Programming Skill ---
#:literate-check-block-balance
#:check-tangle-sync
#:*tangle-targets*
;; --- Emacs Edit Skill ---
#:emacs-edit-read-file
#:emacs-edit-write-file
#:emacs-edit-add-headline
#:emacs-edit-set-property
#:emacs-edit-set-todo
#:emacs-edit-find-headline-by-id
#:emacs-edit-find-headline-by-title
#:emacs-edit-generate-id
#:emacs-edit-id-format
#:emacs-edit-ast-to-org
#:emacs-edit-modify
;; --- Utils Org Skill ---
#:utils-org-read-file
#:utils-org-write-file
#:utils-org-add-headline
#:utils-org-set-property
#:utils-org-set-todo
#:utils-org-find-headline-by-id
#:utils-org-find-headline-by-title
#:utils-org-generate-id
#:utils-org-id-format
#:utils-org-ast-to-org
#:utils-org-modify
;; --- Lisp Utils Skill ---
#:lisp-utils-validate
#:lisp-utils-check-structural
#:lisp-utils-check-syntactic
#:lisp-utils-check-semantic
#:lisp-utils-register
;; --- Utils Lisp Skill ---
#:utils-lisp-validate
#:utils-lisp-check-structural
#:utils-lisp-check-syntactic
#:utils-lisp-check-semantic
#:utils-lisp-eval
#:utils-lisp-format
#:utils-lisp-list-definitions
#:utils-lisp-structural-extract
#:utils-lisp-structural-wrap
#:utils-lisp-structural-inject
#:utils-lisp-structural-slurp
#:utils-lisp-register
;; --- Config Manager & Diagnostics Skill ---
#:get-oc-config-dir
@@ -242,4 +251,19 @@ The ~package.lisp~ file defines the public API of the ~opencortex~ harness.
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
(format t "~a~%" formatted-msg)
(finish-output)))
;; --- Debugger Hook ---
(setf *debugger-hook* (lambda (condition hook)
"Friendly error handler - shows diagnostic message instead of raw debugger."
(format t "~%")
(format t "┌─────────────────────────────────────────────┐~%")
(format t "│ ERROR: ~A~%" (type-of condition))
(format t "│~%")
(format t "│ Run: opencortex doctor~%")
(format t "│ For system diagnostics~%")
(format t "└─────────────────────────────────────────────┘~%")
(format t "~%")
(format t "Details: ~A~%" condition)
(finish-output)
(uiop:quit 1)))
#+end_src

81
harness/perceive.lisp
View File

@@ -1,66 +1,35 @@
(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.")
"Sensors that are processed in dedicated threads.")
(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.")
"The Org ID of the node the user is currently interacting with.")
(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."
"Inject a raw message into the signal processing pipeline."
(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)
(setf (getf raw-message :depth) depth)
(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))
(restart-case (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)
@@ -70,61 +39,33 @@
(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."
"Stage 1 of the metabolic pipeline: Normalize sensory input."
(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
(snapshot-memory)
(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)))
(setf *foveal-focus-id* (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
(setf *interrupt-flag* t))))
((eq type :RESPONSE)
(harness-log "GATE [Perceive]: Act Result -> ~a"
(getf payload :status))))
(harness-log "GATE [Perceive]: Act Result -> ~a" (getf payload :status))))
;; Update signal status
(setf (getf signal :status) :perceived)
(setf (getf signal :foveal-focus) *foveal-focus-id*)
signal))

324
harness/reason.lisp
View File

@@ -1,63 +1,30 @@
(in-package :opencortex)
(defvar *probabilistic-backends* (make-hash-table :test 'equal)
"Registry mapping provider keywords (:openrouter, :ollama) to their calling functions.")
(defvar *probabilistic-backends* (make-hash-table :test 'equal))
(defvar *provider-cascade* nil
"Ordered list of provider keywords to try. First available provider wins.")
(defvar *provider-cascade* nil)
(defvar *model-selector-fn* nil
"Optional function that selects a specific model for each provider.
Signature: (funcall fn provider context) => model-name-string")
(defvar *model-selector-fn* nil)
(defvar *consensus-enabled-p* nil
"When T, run multiple providers and compare results for critical decisions.")
(defvar *consensus-enabled-p* nil)
(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)
@@ -65,22 +32,10 @@
(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 ""))
@@ -90,295 +45,88 @@
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
(loop for (k v) on plist by #'cddr
collect (if (and (symbolp k) (not (keywordp k)))
(intern (string k) :keyword)
k)
collect (car rest))))
collect v)))
(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"))
(rejection-trace (proto-get (proto-get context :payload) :rejection-trace)))
;; 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."))))
;; Inject Reflection Loop feedback if a previous proposal was rejected
(reflection-feedback (if rejection-trace
(format nil "~%~%PREVIOUS PROPOSAL REJECTED:~%Your previous proposal was rejected by the deterministic safety gates.~%Rejection Trace: ~a~%You MUST fix the syntax or logic error described above and try again." rejection-trace)
""))
(system-prompt (format nil
"IDENTITY: ~a~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
reflection-feedback
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)))))
(rejection-trace (proto-get (proto-get context :payload) :rejection-trace))
(prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
(raw-prompt (if prompt-generator
(funcall prompt-generator context)
(let ((p (proto-get (proto-get context :payload) :text)))
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
(reflection-feedback (if rejection-trace
(format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
""))
(system-prompt (format nil "IDENTITY: ~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
assistant-name reflection-feedback tool-belt global-context system-logs)))
(let* ((thought (probabilistic-call raw-prompt :system-prompt system-prompt :context context))
(cleaned (strip-markdown thought)))
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (char= (char cleaned 0) #\((char= (char cleaned 0) #\()))
(handler-case
(let ((parsed (read-from-string cleaned)))
(if (listp parsed)
(normalize-plist-keywords parsed)
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))
(error () (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (or cleaned "No response")))))))
(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
(when (or (null trigger) (ignore-errors (funcall trigger context)))
(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
(when (and (listp next-action)
(member (proto-get next-action :type) '(:LOG :EVENT)))
(harness-log "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill))
(return-from deterministic-verify next-action))
(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)))
(unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message)))
(return-from reason-gate signal))
;; Reflection Loop: Retry up to 3 times if deterministic gates reject
(let ((retries 3)
(current-signal (copy-tree signal))
(last-rejection nil))
(loop
(when (<= retries 0)
(harness-log "REASON: Reflection loop exhausted. Final rejection.")
(setf (getf signal :approved-action) last-rejection)
(setf (getf signal :status) :reasoned)
(return signal))
(when last-rejection
(setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
(let ((candidate (think current-signal)))
(harness-log "REASON: candidate type = ~a" (type-of candidate))
(if (and candidate
(listp candidate)
(or (keywordp (car candidate))
(eq (car candidate) 'TYPE)
(eq (car candidate) 'type)))
(if (and candidate (listp candidate))
(let ((verified (deterministic-verify candidate current-signal)))
(if (member (getf verified :type) '(:LOG :EVENT :log :event))
(progn
(harness-log "REASON: Proposal rejected by gate. Retrying (~a left)." (1- retries))
(decf retries)
(setf last-rejection verified))
(if (member (getf verified :type) '(:LOG :EVENT))
(progn (decf retries) (setf last-rejection verified))
(progn
(setf (getf signal :approved-action) verified)
(setf (getf signal :status) :reasoned)
(return signal))))
(progn
(harness-log "REASON: Invalid candidate type ~a, dropping" (type-of candidate))
(setf (getf signal :approved-action) nil)
(setf (getf signal :status) :reasoned)
(return signal))))))))

30
harness/run-all-tests.lisp
View File

@@ -1,30 +0,0 @@
(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))
(let ((oc-dir (or (uiop:getenv "OC_DATA_DIR")
(namestring (truename "./")))))
(push (uiop:ensure-directory-pathname oc-dir) asdf:*central-registry*))
(ql:quickload '(:opencortex :opencortex/tests) :silent t)
(format t "~%=== Initializing Skills BEFORE loading tests ===~%")
(opencortex:initialize-all-skills)
(format t "~%=== Running ALL Test Suites ===~%")
(dolist (suite-spec '(("OPENCORTEX-BOOT-TESTS" "BOOT-SUITE")
("OPENCORTEX-COMMUNICATION-TESTS" "COMMUNICATION-PROTOCOL-SUITE")
("OPENCORTEX-PIPELINE-ACT-TESTS" "PIPELINE-ACT-SUITE")
("OPENCORTEX-MEMORY-TESTS" "MEMORY-SUITE")
("OPENCORTEX-ENGINEERING-STANDARDS-TESTS" "ENGINEERING-STANDARDS-SUITE")
("OPENCORTEX-DIAGNOSTICS-TESTS" "DIAGNOSTICS-SUITE")
("OPENCORTEX-GATEWAY-MANAGER-TESTS" "GATEWAY-SUITE")
("OPENCORTEX-TUI-TESTS" "TUI-SUITE")
("OPENCORTEX-LLM-GATEWAY-TESTS" "LLM-GATEWAY-SUITE")))
(let ((pkg (find-package (first suite-spec))))
(when pkg
(let ((suite-sym (find-symbol (second suite-spec) pkg)))
(when suite-sym
(format t "~&--- Suite: ~A ---~%" (first suite-spec))
(fiveam:run! suite-sym))))))
(format t "~%=== ALL TESTS COMPLETE ===~%")

2
harness/setup.org
View File

@@ -23,7 +23,7 @@ To maintain sovereignty, the harness must remain a "dumb" bus. It should not kno
** The Installer Script (opencortex.sh)
The shell script is the primary entry point. It handles the initial git clone, dependency installation, and literate tangle.
#+begin_src bash :tangle setup.shsetup.sh
#+begin_src bash :tangle setup.sh
#!/bin/bash
# (The content here is a duplicate of the main opencortex.sh for literate consistency)
# [Note: Implementation is already verified in the top-level script]

3
harness/setup.sh Normal file
View File

@@ -0,0 +1,3 @@
#!/bin/bash
# (The content here is a duplicate of the main opencortex.sh for literate consistency)
# [Note: Implementation is already verified in the top-level script]

368
harness/skills.lisp
View File

@@ -2,42 +2,27 @@
(defun COSINE-SIMILARITY (v1 v2)
"Computes cosine similarity between two vectors."
(let* ((len1 (length v1))
(len2 (length v2)))
(let* ((len1 (length v1)) (len2 (length v2)))
(if (or (zerop len1) (zerop len2))
0.0
(let* ((dot 0.0d0)
(n1 0.0d0)
(n2 0.0d0))
(let* ((dot 0.0d0) (n1 0.0d0) (n2 0.0d0))
(dotimes (i (min len1 len2))
(let* ((x (coerce (elt v1 i) 'double-float))
(y (coerce (elt v2 i) 'double-float)))
(incf dot (* x y))
(incf n1 (* x x))
(incf n2 (* y y))))
(if (or (zerop n1) (zerop n2))
0.0
(/ dot (sqrt (* n1 n2))))))))
;; TODO: Stub for vault - implement later
(defun VAULT-MASK-STRING (s) "[MASKED]")
(let* ((x (coerce (elt v1 i) 'double-float)) (y (coerce (elt v2 i) 'double-float)))
(incf dot (* x y)) (incf n1 (* x x)) (incf n2 (* y y))))
(if (or (zerop n1) (zerop n2)) 0.0 (/ dot (sqrt (* n1 n2))))))))
(defun VAULT-MASK-STRING (s) (declare (ignore s)) "[MASKED]")
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn)
(defvar *skills-registry* (make-hash-table :test 'equal))
(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))
(defstruct skill-entry filename (status :discovered) error-log (load-time 0))
(defun find-triggered-skill (context)
"Returns the highest priority skill whose trigger matches context AND has a probabilistic prompt."
"Returns the highest priority skill whose trigger matches context."
(let ((triggered nil))
(maphash (lambda (name skill)
(declare (ignore name))
@@ -65,37 +50,30 @@
(push name seen)
(let ((skill (gethash (string-downcase (string name)) *skills-registry*)))
(when skill
(dolist (dep (skill-dependencies skill))
(visit dep))))
(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 ((dependencies nil) (id nil) (content (uiop:read-file-string filepath)))
(let ((id-start (search ":ID:" content)))
(when id-start
(let ((id-end (position #\Newline content :start id-start)))
(when id-end
(setf id (string-trim " " (subseq content (+ id-start 4) id-end)))))))
;; Simple DEPENDS_ON extraction
(when id-end (setf id (string-trim " " (subseq content (+ id-start 4) id-end)))))))
(let ((pos 0))
(loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos))
do (let ((end (position #\Newline content :start pos)))
(when end
(let ((line (string-trim " " (subseq content (+ pos 13) end))))
(dolist (d (uiop:split-string line :separator '(#\Space #\Tab)))
(unless (string= d "")
(push d dependencies))))
(unless (string= d "") (push d 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)."
"Returns a list of skill filepaths sorted by dependency."
(let ((files (uiop:directory-files skills-dir "org-skill-*.org"))
(adj (make-hash-table :test 'equal))
(name-to-file (make-hash-table :test 'equal))
@@ -124,7 +102,7 @@
(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)
(error "Circular dependency detected")
(visit dep-file))))))
(setf (gethash node-key stack) nil)
(setf (gethash node-key visited) t)
@@ -136,91 +114,59 @@
(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-utils-validate)
(lisp-utils-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.")))))
"Checks if a string contains valid Common Lisp forms."
(handler-case
(let ((*read-eval* nil))
(with-input-from-string (s (format nil "(progn ~a)" code-string))
(loop for form = (read s nil :eof) until (eq form :eof)))
(values t nil))
(error (c) (values nil (format nil "~a" c)))))
(defun extract-tangle-target (line)
"Extracts the value of the :tangle header from an org src block line.
Handles both simple strings and parenthesized elisp expressions."
"Extracts the value of the :tangle header."
(let ((pos (search ":tangle" line)))
(when pos
(let ((rest (string-trim '(#\Space #\Tab) (subseq line (+ pos 7)))))
(if (char= (char rest 0) #\()
;; It's an elisp expression, find the matching closing paren
(let ((balance 0)
(end nil))
(dotimes (i (length rest))
(let ((ch (char rest i)))
(cond ((char= ch #\() (incf balance))
((char= ch #\)) (decf balance)))
(when (and (> i 0) (= balance 0))
(setf end (1+ i))
(return-from extract-tangle-target (subseq rest 0 end)))))
rest)
;; It's a simple string, stop at next space
(let ((end (position #\Space rest)))
(if end (subseq rest 0 end) rest)))))))
(let ((end (position #\Space rest)))
(if end (subseq rest 0 end) rest))))))
(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."
"Parses and evaluates Lisp blocks from an Org file."
(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 "")
(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" clean-line)
(setf in-lisp-block t)
(let ((tangle-target (extract-tangle-target clean-line)))
(if (or (and tangle-target (not (search "/tests" tangle-target)) (not (search ":tangle no" clean-line)))
(and (not tangle-target) (not (search ":tangle no" clean-line))))
(setf collect-this-block t)
(setf collect-this-block nil))))
(let ((target (extract-tangle-target clean-line)))
;; Collect if there's no tangle target (inherits from file)
;; or if it's a lisp file and NOT a test.
(setf collect-this-block (or (null target)
(and (not (search "no" target))
(not (search "/tests" target)))))))
((uiop:string-prefix-p "#+end_src" clean-line)
(setf in-lisp-block nil)
(setf collect-this-block nil))
(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)))
(uiop:string-prefix-p ":END:" (string-upcase clean-line))
(uiop:string-prefix-p ":ID:" (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)
(setf (skill-entry-status entry) :ready)
(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 valid-p (error err)))
(unless (find-package pkg-name)
(let ((new-pkg (make-package pkg-name :use '(:cl))))
(use-package :opencortex new-pkg)))
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :opencortex new-pkg)))
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
(harness-log "LOADER: Evaluating code for '~a' in package ~a" skill-base-name (package-name *package*))
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
;; Export symbols back to :OPENCORTEX for discoverability and testing
@@ -229,11 +175,14 @@ Only loads blocks that specify a .lisp tangle target, ignoring tests and example
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
(subseq raw-name 10)
raw-name)))
(harness-log "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
(do-symbols (sym (find-package pkg-name))
(when (eq (symbol-package sym) (find-package pkg-name))
(let ((sn (symbol-name sym)))
(when (or (uiop:string-prefix-p raw-name sn)
(uiop:string-prefix-p short-name sn))
(uiop:string-prefix-p short-name sn)
(string-equal sn "DOCTOR-MAIN")
(string-equal sn "RUN-SETUP-WIZARD"))
(harness-log "LOADER: Exporting ~a to :OPENCORTEX" sn)
;; Resolve potential name conflicts by uninterning first
(let ((existing (find-symbol sn target-pkg)))
@@ -242,226 +191,19 @@ Only loads blocks that specify a .lisp tangle target, ignoring tests and example
(import sym target-pkg)
(export sym target-pkg))))))
(setf (skill-entry-status entry) :ready)
t)))
(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)))))
(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))))
(harness-log "LOADER ERROR in skill '~a': ~a" skill-base-name c)
(setf (skill-entry-status entry) :failed) nil))))
(defun initialize-all-skills ()
"Scans the directory defined by SKILLS_DIR and hot-loads skills using topological order."
"Initializes all skills from SKILLS_DIR."
(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))
(skills-dir (uiop:ensure-directory-pathname (or env-path (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))))
(unless (uiop:directory-exists-p skills-dir) (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)
(let ((perm (ignore-errors (uiop:symbol-call :opencortex.skills.org-skill-tool-permissions :get-tool-permission name))))
(unless (eq perm :deny)
(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 :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"))
(abs-path (namestring (uiop:ensure-absolute-pathname file (uiop:getcwd)))))
(and (str:starts-with-p memex-root abs-path)
(not (search ".." abs-path)))))
: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"))
(abs-path (namestring (uiop:ensure-absolute-pathname file (uiop:getcwd)))))
(and (str:starts-with-p memex-root abs-path)
(not (search ".." abs-path))
(not (str:ends-with-p ".org" abs-path))))) ;; Force AST tools for .org files
: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"))
(abs-path (namestring (uiop:ensure-absolute-pathname file (uiop:getcwd)))))
(and (str:starts-with-p memex-root abs-path)
(not (search ".." abs-path))
(not (str:ends-with-p ".org" abs-path))))) ;; Force AST tools for .org files
: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))))))
(harness-log "LOADER: Initializing ~a skills..." (length sorted-files))
(dolist (file sorted-files)
(load-skill-from-org file))
(harness-log "LOADER: Boot Complete."))))

2
harness/skills.org
View File

@@ -238,7 +238,7 @@ The ~opencortex~ Skill Engine enables **Late-Binding Intelligence**, allowing th
#+end_src
* Test Suite
#+begin_src lisp :tangle tests/boot-sequence-tests.lisp
#+begin_src lisp :tangle ../tests/boot-sequence-tests.lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))

61
harness/tui-client.lisp
View File

@@ -1,51 +1,33 @@
(in-package :cl-user)
(defpackage :opencortex.tui
(:use :cl :croatoan)
(:use :cl :croatoan :usocket)
(: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) "Full chronological log of messages.")
(defvar *scroll-index* 0 "Offset for history rendering.")
(defvar *status-text* "Connecting...")
(defvar *chat-history* nil)
(defvar *scroll-index* 0)
(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 *is-running* t)
(defvar *queue-lock* (bt:make-lock))
(defvar *incoming-msgs* nil)
(defun enqueue-msg (msg)
"Thread-safe addition to incoming message queue."
(bt:with-lock-held (*queue-lock*)
(push msg *incoming-msgs*)))
(setf *incoming-msgs* (append *incoming-msgs* (list msg)))))
(defun dequeue-msgs ()
"Thread-safe retrieval of incoming messages."
(bt:with-lock-held (*queue-lock*)
(let ((msgs (nreverse *incoming-msgs*)))
(let ((msgs *incoming-msgs*))
(setf *incoming-msgs* nil)
msgs)))
(defun get-line-style (text)
"Determines croatoan attributes based on content patterns."
(cond
((uiop:string-prefix-p "*" text) '(:bold :yellow))
((uiop:string-prefix-p "⬆" text) '(:cyan))
@@ -54,45 +36,46 @@
(t nil)))
(defun render-chat (win)
"Renders the chat history with scrolling and styling."
(clear win)
(let* ((h (height win))
(view-height (- h 2))
(view-height (max 0 (- h 2)))
(history-len (length *chat-history*))
(start-idx *scroll-index*)
(end-idx (min history-len (+ start-idx view-height)))
(slice (reverse (subseq *chat-history* start-idx end-idx))))
(loop for msg in slice
for i from 1
do (let ((style (get-line-style msg)))
(add-string win (format nil "│ ~a" msg) :y i :x 1 :attributes style)))
do (add-string win (format nil "│ ~a" msg) :y i :x 1 :attributes (get-line-style msg)))
(refresh win)))
(defun handle-backspace ()
"Deletes last character from input buffer."
(when (> (fill-pointer *input-buffer*) 0)
(decf (fill-pointer *input-buffer*))))
(defun handle-return (stream)
"Process input buffer as message or command."
(let ((cmd (coerce *input-buffer* 'string)))
(setf (fill-pointer *input-buffer*) 0)
(when (> (length cmd) 0)
(enqueue-msg (format nil "⬆ ~a" cmd))
(handler-case
(when (and stream (open-stream-p stream))
(format stream "~a" (opencortex:frame-message (list :TYPE :EVENT
:META (list :SOURCE :tui)
:PAYLOAD (list :SENSOR :user-input :TEXT cmd))))
(finish-output stream))
(progn
(when (and stream (open-stream-p stream))
(let* ((msg (list :TYPE :EVENT
:META (list :SOURCE :tui)
:PAYLOAD (list :SENSOR :user-input :TEXT cmd)))
(payload (format nil "~s" msg))
(len (length payload)))
(format stream "~6,'0x~a" len payload)
(finish-output stream)))
(enqueue-msg "✓ Sent"))
(error (c)
(push "ERROR: Connection to daemon lost." *chat-history*)
(format t "Send error: ~a~%" c)
(enqueue-msg "ERROR: Connection to daemon lost.")
(setf *is-running* nil))))
(when (string= cmd "/exit") (setf *is-running* nil))
(when (string= cmd "/clear") (setf *chat-history* nil))))
(defun main ()
"Initializes ncurses and starts the TUI event loop."
(handler-case
(setf *socket* (usocket:socket-connect *daemon-host* *daemon-port*))
(error (e) (format t "Offline: ~a~%" e) (return-from main)))
@@ -101,19 +84,14 @@
(unwind-protect
(with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t)
(let* ((h (height scr)) (w (width scr)))
(unless (and h w)
(error "Screen dimensions are NIL: h=~a, w=~a" h w))
(let ((chat-win (make-instance 'window :height (- h 5) :width (- w 2) :position '(1 1) :border t))
(input-win (make-instance 'window :height 1 :width (- w 2) :position (list (- h 2) 1) :border t)))
(setf (input-blocking input-win) nil)
(loop :while *is-running* :do
(let ((msgs (dequeue-msgs)))
(when msgs
(dolist (m msgs) (push m *chat-history*))
(render-chat chat-win)))
(let* ((ev (get-event input-win))
(ch (when (and ev (typep ev 'event)) (event-key ev))))
(when ch
@@ -121,7 +99,6 @@
((or (eq ch #\Newline) (eq ch #\Return)) (handle-return *stream*))
((or (eq ch :backspace) (eq ch (code-char 127))) (handle-backspace))
((characterp ch) (vector-push-extend ch *input-buffer*))))
(clear input-win)
(add-string input-win (format nil "▶ ~a" (coerce *input-buffer* 'string)) :y 0 :x 1)
(refresh input-win))