fix: kernel communication and UX robustness
- Implement outbound OACP bridge by passing streams through cognitive loop. - Robustify 'think' and 'dispatch-action' with salvage logic and case-insensitivity. - Fix skill loading crashes due to undefined functions in skeletal skills. - Update org-agent.el to cleanly manage 'Thinking...' status state.
This commit is contained in:
805
docs/README.org
805
docs/README.org
@@ -1,7 +1,9 @@
|
||||
#+TITLE: org-agent: The Neurosymbolic Kernel
|
||||
#+AUTHOR: User
|
||||
#+CREATED: [2026-03-17 Tue]
|
||||
#+UPDATED: [2026-03-24 Tue]
|
||||
#+UPDATED: [2026-04-01 Wed]
|
||||
#+FILETAGS: :platform:kernel:lisp:psf:
|
||||
#+STARTUP: content
|
||||
|
||||
A hyper-minimalist, self-editing, proactive AI agent framework. `org-agent` acts as the "executive soul" of a personal OS, using Org-mode as its native memory and Common Lisp as its deterministic reasoning engine.
|
||||
|
||||
@@ -16,10 +18,10 @@ The `org-agent` kernel (the Daemon) MUST remain a minimalist microkernel. It han
|
||||
** Why Org-mode? (Homoiconic Memory)
|
||||
Most agent frameworks rely on a messy combination of Python scripts, JSON states, and Markdown prompts. This breaks the human-agent interface. JSON is for machines; Markdown is for humans.
|
||||
|
||||
*Org-mode is for both.* It provides a rigorous, hierarchical Abstract Syntax Tree (AST) that a machine can navigate deterministically, while remaining a perfectly ergonomic, human-readable text document. In this system, your notes, your tasks, your prompts, and your agent's code all live in the exact same format.
|
||||
*Org-mode is for both.* It provides a hierarchical Abstract Syntax Tree (AST) that a machine can navigate deterministically, while remaining a perfectly ergonomic, human-readable text document.
|
||||
|
||||
** Why Common Lisp? (The Kernel vs. The Actuators)
|
||||
The `org-agent` kernel is built in Common Lisp to provide a persistent, high-performance background process (SBCL) that maintains a live, threaded Object Store in RAM. It performs heavy neurosymbolic reasoning asynchronously, decoupled from any single user interface.
|
||||
The `org-agent` kernel is built in Common Lisp to provide a persistent, high-performance background process (SBCL) that maintains a live, threaded Object Store in RAM.
|
||||
|
||||
This architecture treats all interfaces as external **Actuators** and **Sensors**:
|
||||
- **Editor Actuator (Emacs):** A sensor array that detects file changes and executes structural refactoring.
|
||||
@@ -83,153 +85,736 @@ sequenceDiagram
|
||||
end
|
||||
#+end_src
|
||||
|
||||
* The Architecture: The Cognitive Loop
|
||||
* System Definition
|
||||
|
||||
The core engine is agnostic to both business logic and communication channels. It routes data through a strict four-stage cognitive pipeline:
|
||||
This section defines the ASDF system, its dependencies, and the loading order of the modules.
|
||||
|
||||
1. **Perceive:** Sensors (Emacs, Webhooks, CRON) send updates over the Org-Agent Communication Protocol (OACP). The kernel updates its live Object Store.
|
||||
2. **Think (System 1):** The `neuro.lisp` module queries an LLM (e.g., Gemini, OpenAI, or local models) based on the context, asking for an intuitive, pattern-matched suggestion. It returns an *unverified* proposed action.
|
||||
3. **Decide (System 2):** The `symbolic.lisp` module is the absolute gatekeeper. It takes the LLM's proposal and runs it through strict Lisp constraints (e.g., "A parent task cannot be marked DONE if it has active TODO children"). If the logic fails, the LLM is overruled.
|
||||
4. **Act:** Verified commands are dispatched to the appropriate Actuators (refactoring a buffer, sending a Signal message, or updating a database).
|
||||
#+begin_src lisp :tangle ../org-agent.asd
|
||||
(defsystem :org-agent
|
||||
:name "org-agent"
|
||||
:author "Amr"
|
||||
:version "0.1.0"
|
||||
:license "MIT"
|
||||
:description "The Neurosymbolic Lisp Machine Kernel"
|
||||
:depends-on (:usocket :cl-json :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot)
|
||||
:serial t
|
||||
:components ((:module "src"
|
||||
:components ((:file "package")
|
||||
(:file "protocol")
|
||||
(:file "object-store")
|
||||
(:file "context")
|
||||
(:file "embedding")
|
||||
(:file "skills")
|
||||
(:file "neuro")
|
||||
(:file "symbolic")
|
||||
(:file "core"))))
|
||||
:build-operation "program-op"
|
||||
:build-pathname "org-agent-server"
|
||||
:entry-point "org-agent:main"
|
||||
:in-order-to ((test-op (test-op :org-agent/tests))))
|
||||
|
||||
* Extensibility: The Org-Native Skill Standard
|
||||
(defsystem :org-agent/tests
|
||||
:depends-on (:org-agent :fiveam)
|
||||
:components ((:module "tests"
|
||||
:components ((:file "oacp-tests")
|
||||
(:file "cognitive-loop-tests"))))
|
||||
:perform (test-op (o s)
|
||||
(uiop:symbol-call :fiveam :run! (uiop:find-symbol* :oacp-suite :org-agent-tests))
|
||||
(uiop:symbol-call :fiveam :run! (uiop:find-symbol* :cognitive-suite :org-agent-cognitive-tests))))
|
||||
#+end_src
|
||||
|
||||
To keep the core microkernel minimal, all capabilities (API connectors, GTD logic, Atomic Notes (Zettelkasten) memory management) are abstracted into **Skills**.
|
||||
* The Kernel Core
|
||||
|
||||
Adhering to the Lisp Machine Mandate (Code is Data), a skill is not a Python folder. A skill is a single `.org` file located in the Atomic Notes (Zettelkasten) directory.
|
||||
The physical implementation of the daemon, tangled from this Org document into =src/=.
|
||||
|
||||
The kernel parses these `.org` files at startup, extracts the `#+begin_src lisp` blocks, and hot-loads them into the live system. You can define a System 1 Prompt and a System 2 Verification Rule entirely within your personal notes.
|
||||
** Namespace & API
|
||||
#+begin_src lisp :tangle ../src/package.lisp
|
||||
(defpackage :org-agent
|
||||
(:use :cl)
|
||||
(:export
|
||||
;; --- OACP Protocol ---
|
||||
#:frame-message
|
||||
#:parse-message
|
||||
#:make-hello-message
|
||||
|
||||
;; --- Daemon Lifecycle ---
|
||||
#:start-daemon
|
||||
#:stop-daemon
|
||||
#:kernel-log
|
||||
#:main
|
||||
|
||||
;; --- Object Store (CLOSOS) ---
|
||||
#:ingest-ast
|
||||
#:lookup-object
|
||||
#:list-objects-by-type
|
||||
#:*object-store*
|
||||
#:org-object
|
||||
#:org-object-id
|
||||
#:org-object-type
|
||||
#:org-object-attributes
|
||||
#:org-object-children
|
||||
#:org-object-vector
|
||||
#:org-object-content
|
||||
#:snapshot-object-store
|
||||
#:rollback-object-store
|
||||
#:send-swarm-packet
|
||||
|
||||
;; --- Context API (Peripheral Vision) ---
|
||||
#:context-query-store
|
||||
#:context-get-active-projects
|
||||
#:context-get-recent-completed-tasks
|
||||
#:context-list-all-skills
|
||||
#:context-get-skill-source
|
||||
#:context-get-system-logs
|
||||
#:context-filter-sparse-tree
|
||||
#:context-resolve-path
|
||||
#:context-get-skill-telemetry
|
||||
|
||||
;; --- Cognitive Loop & Event Bus ---
|
||||
#:perceive
|
||||
#:think
|
||||
#:decide
|
||||
#:act
|
||||
#:cognitive-loop
|
||||
#:inject-stimulus
|
||||
#:dispatch-action
|
||||
#:register-actuator
|
||||
#:spawn-task
|
||||
|
||||
;; --- Skill Engine ---
|
||||
#:load-skill-from-org
|
||||
#:validate-lisp-syntax
|
||||
#:find-triggered-skill
|
||||
#:defskill
|
||||
#:*skills-registry*
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-trigger-fn
|
||||
#:skill-neuro-prompt
|
||||
#:skill-symbolic-fn
|
||||
|
||||
;; --- Neuro (System 1) ---
|
||||
#:ask-neuro
|
||||
#:register-neuro-backend
|
||||
#:register-auth-provider
|
||||
#:get-provider-auth
|
||||
#:distill-prompt
|
||||
#:get-embedding
|
||||
#:cosine-similarity
|
||||
#:find-most-similar
|
||||
#:openrouter-get-available-models
|
||||
#:*provider-cascade*
|
||||
#:economist-route-task
|
||||
|
||||
;; --- Symbolic Logic ---
|
||||
#:list-objects-with-attribute
|
||||
#:org-id-new
|
||||
|
||||
;; --- AST Helpers ---
|
||||
#:find-headline-missing-id))
|
||||
#+end_src
|
||||
|
||||
* Security & Isolation
|
||||
** Communication (OACP)
|
||||
#+begin_src lisp :tangle ../src/protocol.lisp
|
||||
(in-package :org-agent)
|
||||
|
||||
Using `eval` on text generated by LLMs or extracted from text files is fundamentally dangerous. `org-agent` implements strict defense-in-depth:
|
||||
(defun frame-message (msg-string)
|
||||
"Prefix MSG-STRING with a 6-character hex length (lowercase)."
|
||||
(let ((len (length msg-string)))
|
||||
(format nil "~(~6,'0x~)~a" len msg-string)))
|
||||
|
||||
** Layer 1: Lisp-Level Sandboxing
|
||||
- **Reader Safety:** `*read-eval*` is strictly disabled during AST parsing, completely neutralizing reader macro injection attacks (`#.(uiop:run-program ...)`).
|
||||
- **Package Jailing:** Every Org-Native skill is dynamically compiled into its own isolated Lisp package (`:org-agent.skills.<name>`). Skills cannot accidentally (or maliciously) overwrite the core System 2 gatekeeper or collide with other skills.
|
||||
(defun parse-message (framed-string)
|
||||
"Extract and parse the S-expression from a framed string."
|
||||
(when (< (length framed-string) 6)
|
||||
(error "Framed string too short"))
|
||||
(let* ((len-str (subseq framed-string 0 6))
|
||||
(actual-msg (subseq framed-string 6))
|
||||
(expected-len (ignore-errors (parse-integer len-str :radix 16))))
|
||||
(unless expected-len
|
||||
(error "Invalid hex length prefix: ~a" len-str))
|
||||
(unless (= expected-len (length actual-msg))
|
||||
(error "Message length mismatch. Expected ~a, got ~a" expected-len (length actual-msg)))
|
||||
(read-from-string actual-msg)))
|
||||
|
||||
** Layer 2: OS-Level Containerization
|
||||
The entire Common Lisp kernel can be isolated within a "Hardware Compartment" to protect the host OS.
|
||||
(defun make-hello-message (version)
|
||||
"Construct the standard HELLO handshake message."
|
||||
(list :type :EVENT
|
||||
:payload (list :action :handshake
|
||||
:version version
|
||||
:capabilities '(:auth :swank :org-ast))))
|
||||
#+end_src
|
||||
|
||||
* Documentation
|
||||
** Perceptual Memory (Object Store)
|
||||
#+begin_src lisp :tangle ../src/object-store.lisp
|
||||
(in-package :org-agent)
|
||||
|
||||
Detailed specifications and planning documents are located in the [[file:docs/][docs/]] directory:
|
||||
- [[file:docs/PRD.org][Product Requirements Document (PRD)]]
|
||||
- [[file:docs/PROTOCOL.org][Communication Protocol (OACP)]]
|
||||
- [[file:docs/PHASE_2_ROADMAP.org][Phase 2 Roadmap]]
|
||||
- Specialized PRDs for [[file:docs/PRD_PROJECT_FOUNDRY.org][Project Foundry]], [[file:docs/PRD_ORG_DELIVERY.org][Org Delivery]], [[file:docs/PRD_LLM_CASCADE.org][LLM Cascade]], and more.
|
||||
(defvar *object-store* (make-hash-table :test 'equal))
|
||||
|
||||
* Hardware Compartments (Deployment)
|
||||
(defstruct org-object
|
||||
id type attributes content vector parent-id children version last-sync)
|
||||
|
||||
`org-agent` supports multiple levels of isolation. Choose the compartment that fits your security and performance needs. See the `deploy/` directory for templates.
|
||||
(defun ingest-ast (ast &optional parent-id)
|
||||
(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))
|
||||
(dolist (child contents)
|
||||
(when (listp child) (push (ingest-ast child id) child-ids)))
|
||||
(let ((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 (nreverse child-ids)
|
||||
:version (get-universal-time) :last-sync (get-universal-time))))
|
||||
(setf (gethash id *object-store*) obj)
|
||||
id)))
|
||||
|
||||
** 1. Bare Metal
|
||||
Run directly on your host CPU for maximum performance. Best for development.
|
||||
(defvar *object-store-snapshots* nil)
|
||||
|
||||
** 2. Docker (Standard)
|
||||
The default containerized experience.
|
||||
(defun clone-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)))
|
||||
|
||||
** 3. LXC / Systemd-nspawn
|
||||
Lightweight Linux containers with lower overhead than Docker.
|
||||
(defun snapshot-object-store ()
|
||||
(let ((snapshot (make-hash-table :test 'equal)))
|
||||
(maphash (lambda (id obj) (setf (gethash id snapshot) (clone-org-object obj))) *object-store*)
|
||||
(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)))
|
||||
(kernel-log "MEMORY - Object Store snapshot created.")))
|
||||
|
||||
** 4. Virtual Machines (Debian / Fedora)
|
||||
Strong isolation using Vagrant/VirtualBox. Ensures zero-leakage from the Lisp machine.
|
||||
(defun rollback-object-store (&optional (index 0))
|
||||
(let ((snapshot (nth index *object-store-snapshots*)))
|
||||
(if snapshot
|
||||
(progn (setf *object-store* (getf snapshot :data))
|
||||
(kernel-log "MEMORY - Object Store rolled back to snapshot ~a" index))
|
||||
(kernel-log "MEMORY ERROR - Snapshot ~a not found." index))))
|
||||
|
||||
** 5. Functional Deployment (Guix)
|
||||
Reproducible, declarative environment management.
|
||||
(defun lookup-object (id) (gethash id *object-store*))
|
||||
|
||||
* Installation & Setup Guide
|
||||
(defun list-objects-by-type (type)
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj) (declare (ignore id)) (when (eq (org-object-type obj) type) (push obj results))) *object-store*)
|
||||
results))
|
||||
|
||||
This guide covers the standard distributed deployment: running the `org-agent` daemon on a remote Docker server, connecting to it from your local Emacs instance, and configuring dynamic LLMs (like OpenRouter).
|
||||
(defun find-headline-missing-id (ast)
|
||||
(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)))))
|
||||
|
||||
** Step 1: Server Setup (Global Docker Compose)
|
||||
`org-agent` is designed to fit into a professional multi-app Docker environment.
|
||||
(defun file-name-nondirectory (path)
|
||||
(let ((pos (position #\/ path :from-end t))) (if pos (subseq path (1+ pos)) path)))
|
||||
#+end_src
|
||||
|
||||
1. **Clone the repository on your server:**
|
||||
#+begin_src bash
|
||||
git clone http://10.10.10.43:3000/amr/memex-amero.git /home/amr/memex
|
||||
#+end_src
|
||||
** Peripheral Vision (Context API)
|
||||
#+begin_src lisp :tangle ../src/context.lisp
|
||||
(in-package :org-agent)
|
||||
|
||||
2. **Configure your Environment (.env):**
|
||||
Place your `.env` file in `/docker/compose/` alongside your master `docker-compose.yml`.
|
||||
#+begin_src bash
|
||||
# Create /docker/compose/.env with your keys:
|
||||
# OPENROUTER_API_KEY=your_key_here
|
||||
# ORG_AGENT_DAEMON_PORT=9105
|
||||
# ORG_AGENT_WEB_PORT=8080
|
||||
# MEMEX_DIR=/memex
|
||||
#+end_src
|
||||
(defun context-query-store (&key tag todo-state type)
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let* ((attrs (org-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t))
|
||||
(when (and type (not (eq (org-object-type obj) type))) (setf match nil))
|
||||
(when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil)))
|
||||
(when (and todo-state (not (equal state todo-state))) (setf match nil))
|
||||
(when match (push obj results))))
|
||||
*object-store*)
|
||||
results))
|
||||
|
||||
3. **Integrate into Global Compose:**
|
||||
Add the following service fragment to your master file at `/docker/compose/docker-compose.yml`:
|
||||
#+begin_src yaml
|
||||
services:
|
||||
org-agent:
|
||||
build:
|
||||
context: /home/amr/memex/projects/org-agent
|
||||
dockerfile: deploy/docker/Dockerfile
|
||||
container_name: org-agent
|
||||
restart: unless-stopped
|
||||
ports:
|
||||
- "9105:9105"
|
||||
- "8080:8080"
|
||||
volumes:
|
||||
- /docker/memex:/memex
|
||||
env_file:
|
||||
- .env
|
||||
#+end_src
|
||||
(defun context-get-active-projects ()
|
||||
(remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(context-query-store :tag "project" :type :HEADLINE)))
|
||||
|
||||
4. **Start the Service:**
|
||||
#+begin_src bash
|
||||
cd /docker/compose
|
||||
docker-compose up -d org-agent
|
||||
#+end_src
|
||||
(defun context-get-recent-completed-tasks () (context-query-store :todo-state "DONE" :type :HEADLINE))
|
||||
|
||||
** Step 2: Local Emacs Setup (The Actuator)
|
||||
Your laptop acts as the sensor/actuator array.
|
||||
(defun context-list-all-skills ()
|
||||
(let ((results nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results))
|
||||
*skills-registry*)
|
||||
(sort results #'> :key (lambda (x) (getf x :priority)))))
|
||||
|
||||
1. **Load the Emacs Package:**
|
||||
Evaluate the `org-agent.el` file in your local Emacs.
|
||||
#+begin_src elisp
|
||||
(add-to-list 'load-path "/path/to/local/org-agent/src")
|
||||
(require 'org-agent)
|
||||
#+end_src
|
||||
(defun context-get-skill-source (skill-name)
|
||||
(let* ((filename (format nil "~a.org" skill-name))
|
||||
(skills-dir (merge-pathnames "skills/" (asdf:system-source-directory :org-agent)))
|
||||
(full-path (merge-pathnames filename skills-dir)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
|
||||
2. **Configure the Connection:**
|
||||
Tell Emacs where your Docker server is located.
|
||||
#+begin_src elisp
|
||||
(setq org-agent-host "10.0.0.5") ;; Replace with your server's IP
|
||||
(setq org-agent-port 9105)
|
||||
#+end_src
|
||||
(defun context-get-system-logs (&optional (limit 20))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(let ((count (min limit (length *system-logs*)))) (subseq *system-logs* 0 count))))
|
||||
|
||||
3. **Connect to the Brain:**
|
||||
Run the interactive command to establish the OACP socket.
|
||||
`M-x org-agent-connect`
|
||||
(defun context-get-skill-telemetry (skill-name)
|
||||
(bt:with-lock-held (*telemetry-lock*) (gethash (string-downcase skill-name) *skill-telemetry*)))
|
||||
|
||||
** Step 3: Dynamic Model Configuration (Homoiconic Setup)
|
||||
`org-agent` does not use external JSON config files for its behavior. You configure the agent directly within your Org-mode Memex.
|
||||
(defun context-filter-sparse-tree (ast predicate)
|
||||
(if (listp ast)
|
||||
(let* ((contents (getf ast :contents))
|
||||
(filtered-contents (remove-if #'null (mapcar (lambda (c) (context-filter-sparse-tree c predicate)) contents))))
|
||||
(if (or (funcall predicate ast) (not (null filtered-contents)))
|
||||
(let ((new-ast (copy-list ast))) (setf (getf new-ast :contents) filtered-contents) new-ast)
|
||||
nil))
|
||||
nil))
|
||||
|
||||
1. Open any `.org` file in your Memex (e.g., `settings.org`).
|
||||
2. Add the following property to define your preferred model:
|
||||
#+begin_src org
|
||||
* Agent Settings
|
||||
:PROPERTIES:
|
||||
:LLM_MODEL_OPENROUTER: google/gemini-pro-1.5
|
||||
:END:
|
||||
#+end_src
|
||||
3. **Save the buffer.** The agent instantly detects the change via Emacs, updates its internal Object Store, and routes all future neural thoughts through the selected model.
|
||||
(defun context-resolve-path (path-string)
|
||||
(if (and (stringp path-string) (uiop:string-prefix-p "$" path-string))
|
||||
(let* ((parts (uiop:split-string path-string :separator '(#\/)))
|
||||
(var-name (subseq (car parts) 1)) (var-val (uiop:getenv var-name))
|
||||
(remaining (cl:reduce (lambda (a b) (format nil "~a/~a" a b)) (cdr parts))))
|
||||
(if var-val (let ((clean-val (string-trim '(#\" #\Space) var-val)))
|
||||
(format nil "~a/~a" (string-right-trim "/" clean-val) remaining))
|
||||
path-string))
|
||||
path-string))
|
||||
#+end_src
|
||||
|
||||
To see all available models, simply type `@agent list models` in any Org buffer and save.
|
||||
* System 1 (Neural Engine)
|
||||
** Embedding Logic
|
||||
#+begin_src lisp :tangle ../src/embedding.lisp
|
||||
(in-package :org-agent)
|
||||
|
||||
* The Long-Term Vision: Orders of Autonomy
|
||||
(defun get-embedding (text)
|
||||
(let* ((auth (get-provider-auth :gemini)) (api-key (getf auth :api-key))
|
||||
(endpoint "https://generativelanguage.googleapis.com/v1beta/models/text-embedding-004:embedContent"))
|
||||
(unless api-key (return-from get-embedding nil))
|
||||
(let* ((url (format nil "~a?key=~a" endpoint api-key)) (headers `(("Content-Type" . "application/json")))
|
||||
(body (cl-json:encode-json-to-string `((model . "models/text-embedding-004") (content . ((parts . ((text . ,text)))))))))
|
||||
(handler-case (let* ((response (dex:post url :headers headers :content body))
|
||||
(json (cl-json:decode-json-from-string response)))
|
||||
(cdr (assoc :values (cdr (assoc :embedding json)))))
|
||||
(error (c) (kernel-log "EMBEDDING FAILURE: ~a" c) nil)))))
|
||||
|
||||
The development of `org-agent` follows distinct orders of autonomy, progressing from a basic assistant to a fully sovereign entity.
|
||||
(defun dot-product (v1 v2) (reduce #'+ (mapcar #'* v1 v2)))
|
||||
(defun magnitude (v) (sqrt (reduce #'+ (mapcar (lambda (x) (* x x)) v))))
|
||||
(defun cosine-similarity (v1 v2)
|
||||
(let ((m1 (magnitude v1)) (m2 (magnitude v2))) (if (or (zerop m1) (zerop m2)) 0 (/ (dot-product v1 v2) (* m1 m2)))))
|
||||
|
||||
(defun find-most-similar (query-vector top-k)
|
||||
(let ((similarities nil))
|
||||
(maphash (lambda (id obj) (let ((vec (org-object-vector obj))) (when vec (push (cons (cosine-similarity query-vector vec) obj) similarities)))) *object-store*)
|
||||
(let ((sorted (sort similarities #'> :key #'car))) (subseq sorted 0 (min top-k (length sorted))))))
|
||||
#+end_src
|
||||
|
||||
** Neural Logic
|
||||
#+begin_src lisp :tangle ../src/neuro.lisp
|
||||
(in-package :org-agent)
|
||||
|
||||
(defun get-env (var &optional default) (or (uiop:getenv var) default))
|
||||
|
||||
(defvar *auth-providers* (make-hash-table :test 'equal))
|
||||
(defun register-auth-provider (name fn) (setf (gethash name *auth-providers*) fn))
|
||||
(defun get-provider-auth (provider) (let ((auth-fn (gethash provider *auth-providers*))) (if auth-fn (funcall auth-fn) nil)))
|
||||
|
||||
(defvar *neuro-backends* (make-hash-table :test 'equal))
|
||||
(defvar *provider-cascade* '(:gemini))
|
||||
(defun register-neuro-backend (name fn) (setf (gethash name *neuro-backends*) fn))
|
||||
|
||||
(defun ask-neuro (prompt &key (system-prompt "You are the System 1 engine of a Neurosymbolic Lisp Machine.") (cascade nil))
|
||||
(let ((backends (or cascade *provider-cascade*)))
|
||||
(dolist (backend backends)
|
||||
(let ((backend-fn (gethash backend *neuro-backends*)))
|
||||
(when backend-fn
|
||||
(kernel-log "SYSTEM 1: Attempting backend ~a..." backend)
|
||||
(let ((result (funcall backend-fn prompt system-prompt)))
|
||||
(if (and (stringp result) (search ":LOG" result) (search "Failure" result))
|
||||
(kernel-log "SYSTEM 1: Backend ~a failed. Falling back..." backend)
|
||||
(return-from ask-neuro result))))))
|
||||
"(:type :LOG :payload (:text \"Neural Cascade Failure\"))"))
|
||||
|
||||
(defun execute-gemini-request (prompt system-prompt)
|
||||
(let* ((auth (get-provider-auth :gemini)) (api-key (getf auth :api-key)) (bearer-token (getf auth :bearer-token))
|
||||
(endpoint (or (getf auth :endpoint) "https://generativelanguage.googleapis.com/v1beta/models/gemini-pro:generateContent")))
|
||||
(unless (or api-key bearer-token) (return-from execute-gemini-request "(:type :LOG :payload (:text \"Authentication missing\"))"))
|
||||
(let* ((url (if api-key (format nil "~a?key=~a" endpoint api-key) endpoint))
|
||||
(headers `(("Content-Type" . "application/json") ,@(when bearer-token `(("Authorization" . ,(format nil "Bearer ~a" bearer-token))))))
|
||||
(body (cl-json:encode-json-to-string `((contents . ((parts . ((text . ,(format nil "~a~%~%Prompt: ~a" system-prompt prompt))))))))))
|
||||
(handler-case (let* ((response (dex:post url :headers headers :content body :connect-timeout 10 :read-timeout 30)) (json (cl-json:decode-json-from-string response)))
|
||||
(cdr (assoc :text (cdr (assoc :parts (car (cdr (assoc :parts (car (cdr (assoc :candidates json)))))))))))
|
||||
(error (c) (format nil "(:type :LOG :payload (:text \"Neural Engine Failure: ~a\"))" c))))))
|
||||
|
||||
(defun execute-openrouter-request (prompt system-prompt)
|
||||
(let ((api-key (uiop:getenv "OPENROUTER_API_KEY"))
|
||||
(endpoint "https://openrouter.ai/api/v1/chat/completions")
|
||||
(model "google/gemini-flash-1.5")) ; default fallback
|
||||
;; Dynamically read user's preferred model from the Object Store
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let ((val (getf (org-object-attributes obj) :LLM_MODEL_OPENROUTER)))
|
||||
(when val (setf model val))))
|
||||
*object-store*)
|
||||
(unless api-key (return-from execute-openrouter-request "(:type :LOG :payload (:text \"OpenRouter API Key missing\"))"))
|
||||
(let* ((headers `(("Content-Type" . "application/json")
|
||||
("Authorization" . ,(format nil "Bearer ~a" api-key))
|
||||
("HTTP-Referer" . "https://github.com/amr/org-agent")))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . ,model)
|
||||
(messages . (( (role . "system") (content . ,system-prompt) )
|
||||
( (role . "user") (content . ,prompt) )))))))
|
||||
(handler-case (let* ((response (dex:post endpoint :headers headers :content body :connect-timeout 10 :read-timeout 30))
|
||||
(json (cl-json:decode-json-from-string response)))
|
||||
(cdr (assoc :content (cdr (assoc :message (car (cdr (assoc :choices json))))))))
|
||||
(error (c) (format nil "(:type :LOG :payload (:text \"OpenRouter Failure: ~a\"))" c))))))
|
||||
|
||||
(defun openrouter-get-available-models ()
|
||||
"Fetches available models from OpenRouter."
|
||||
(let ((api-key (uiop:getenv "OPENROUTER_API_KEY")))
|
||||
(unless api-key (return-from openrouter-get-available-models nil))
|
||||
(let ((headers `(("Authorization" . ,(format nil "Bearer ~a" api-key)))))
|
||||
(handler-case
|
||||
(let* ((response (dex:get "https://openrouter.ai/api/v1/models"
|
||||
:headers headers
|
||||
:connect-timeout 60
|
||||
:read-timeout 60))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(data (cdr (assoc :data json)))
|
||||
(results nil))
|
||||
(dolist (item data)
|
||||
(let ((id (cdr (assoc :id item)))
|
||||
(context-len (cdr (assoc :context--length item))))
|
||||
(when id
|
||||
(push (list :id id :context (format nil "~a" (or context-len "unknown"))) results))))
|
||||
(nreverse results))
|
||||
(error (c)
|
||||
(kernel-log "Model Discovery Error: ~a" c)
|
||||
nil)))))
|
||||
|
||||
;; --- Sovereign Service Stubs ---
|
||||
;; These are implemented in specialized skills but registered in the kernel namespace.
|
||||
|
||||
(defun economist-route-task (complexity)
|
||||
"Stub for Neuro-Economic routing. Overridden by skill-economist."
|
||||
(declare (ignore complexity))
|
||||
:gemini) ; Default fallback
|
||||
|
||||
(defun org-id-new ()
|
||||
"Stub for Sovereign ID generation. Overridden by skill-ast-normalization."
|
||||
(format nil "node-~a" (get-universal-time)))
|
||||
|
||||
(register-neuro-backend :gemini #'execute-gemini-request)
|
||||
(register-neuro-backend :openrouter #'execute-openrouter-request)
|
||||
(setf *provider-cascade* '(:openrouter :gemini))
|
||||
|
||||
(defun think (context)
|
||||
(let ((active-skill (find-triggered-skill context)))
|
||||
(if active-skill
|
||||
(progn
|
||||
(kernel-log "SYSTEM 1: Engaging skill '~a'~%" (skill-name active-skill))
|
||||
(let* ((prompt-generator (skill-neuro-prompt active-skill))
|
||||
(prompt (when prompt-generator (funcall prompt-generator context))))
|
||||
(if prompt
|
||||
(let* ((thought (ask-neuro prompt))
|
||||
;; Strip markdown code blocks
|
||||
(cleaned-thought (cl-ppcre:regex-replace-all "(?s)^```(?:lisp)?\\n?(.*?)\\n?```$" (string-trim '(#\Space #\Newline #\Tab) thought) "\\1"))
|
||||
(suggestion (ignore-errors (read-from-string cleaned-thought))))
|
||||
(kernel-log "SYSTEM 1 Suggestion: ~a~%" cleaned-thought)
|
||||
(cond
|
||||
((and suggestion (listp suggestion)) suggestion)
|
||||
;; SALVAGE: If LLM returned plain text or a non-list symbol
|
||||
((and (let ((p (getf context :payload))) (eq (getf p :sensor) :chat-message))
|
||||
(> (length cleaned-thought) 0))
|
||||
(kernel-log "SYSTEM 1: SALVAGING plain-text response.~%")
|
||||
;; Remove common AI conversational filler at the start or end of the response
|
||||
(let* ((no-prefix (cl-ppcre:regex-replace "(?i)^(okay,? |sure,? |i will |i've |i have |here is |got it\\.? |understood\\.? |done\\.? |yes,? )+" cleaned-thought ""))
|
||||
(no-suffix (cl-ppcre:regex-replace "(?i)(\\s+okay,?|\\s+sure,?|\\s+got it\\.?|\\s+understood\\.?)$" no-prefix ""))
|
||||
(payload-text (string-trim '(#\Space #\Newline #\Tab #\") no-suffix)))
|
||||
`(:type :request :target :emacs :payload (:action :insert-at-end :buffer "*org-agent-chat*" :text ,payload-text))))
|
||||
(t (kernel-log "SYSTEM 1 ERROR: Could not parse response as Lisp plist.~%") nil))) '(:type :LOG :payload (:text "Skill triggered (Deterministic only)")))))
|
||||
nil)))
|
||||
|
||||
(defun distill-prompt (full-prompt successful-output)
|
||||
(let ((system-instr "You are a Meta-Cognitive Prompt Architect. DISTILL into template."))
|
||||
(ask-neuro (format nil "PROMPT: ~a~%RESULT: ~a" full-prompt successful-output) :system-prompt system-instr)))
|
||||
|
||||
(defun distillation-loop ()
|
||||
"Autonomous distillation cycle (Skeletal)."
|
||||
(kernel-log "NEURO [Evolution] - Distillation cycle triggered."))
|
||||
#+end_src
|
||||
|
||||
* System 2 (Symbolic Gating)
|
||||
** Symbolic Logic
|
||||
#+begin_src lisp :tangle ../src/symbolic.lisp
|
||||
(in-package :org-agent)
|
||||
|
||||
(defun decide (proposed-action context)
|
||||
(let ((active-skill (find-triggered-skill context)))
|
||||
(if active-skill
|
||||
(let ((symbolic-gate (skill-symbolic-fn active-skill)))
|
||||
(when (and proposed-action (listp proposed-action) (eq (getf proposed-action :type) :REQUEST) (eq (getf (getf proposed-action :payload) :action) :eval))
|
||||
(let ((code (getf (getf proposed-action :payload) :code)) (harness-pkg (find-package :org-agent.skills.org-skill-safety-harness)))
|
||||
(when harness-pkg (unless (ignore-errors (uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code))
|
||||
(kernel-log "SYSTEM 2 [GLOBAL]: Security violation blocked.~%")
|
||||
(return-from decide '(:type :LOG :payload (:text "Blocked by Global Safety Harness")))))))
|
||||
(if symbolic-gate
|
||||
(let ((decision (funcall symbolic-gate proposed-action context)))
|
||||
(if decision (progn (kernel-log "SYSTEM 2: Verified by skill '~a'.~%" (skill-name active-skill)) decision)
|
||||
(progn (kernel-log "SYSTEM 2: REJECTED by skill '~a'.~%" (skill-name active-skill))
|
||||
'(:type :LOG :payload (:text "Action rejected by skill heuristics")))))
|
||||
(progn (kernel-log "SYSTEM 2: Verified (Implicitly safe for skill '~a').~%" (skill-name active-skill)) proposed-action)))
|
||||
nil)))
|
||||
|
||||
(defun list-objects-with-attribute (attr-key attr-val)
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj) (declare (ignore id)) (when (equal (getf (org-object-attributes obj) attr-key) attr-val) (push obj results))) *object-store*)
|
||||
results))
|
||||
#+end_src
|
||||
|
||||
* Skill Engine
|
||||
** Skill Logic
|
||||
#+begin_src lisp :tangle ../src/skills.lisp
|
||||
(in-package :org-agent)
|
||||
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct skill name priority dependencies trigger-fn neuro-prompt symbolic-fn)
|
||||
|
||||
(defmacro defskill (name &key priority dependencies trigger neuro symbolic)
|
||||
`(setf (gethash ,(string-downcase (string name)) *skills-registry*)
|
||||
(make-skill :name ,(string-downcase (string name)) :priority (or ,priority 10) :dependencies ,dependencies
|
||||
:trigger-fn ,trigger :neuro-prompt ,neuro :symbolic-fn ,symbolic)))
|
||||
|
||||
(defun find-triggered-skill (context)
|
||||
(let ((triggered nil))
|
||||
(maphash (lambda (name skill) (declare (ignore name)) (when (ignore-errors (funcall (skill-trigger-fn skill) context)) (push skill triggered))) *skills-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
|
||||
(defun resolve-skill-dependencies (skill-name)
|
||||
(let ((resolved nil) (seen nil))
|
||||
(labels ((visit (name) (unless (member name seen :test #'equal) (push name seen)
|
||||
(let ((skill (gethash (string-downcase (string name)) *skills-registry*)))
|
||||
(when skill (dolist (dep (skill-dependencies skill)) (visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name) (nreverse resolved))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
(when (uiop:file-exists-p filepath)
|
||||
(let* ((content (uiop:read-file-string filepath)) (lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil) (lisp-code "") (dependencies nil) (skill-base-name (pathname-name filepath))
|
||||
(pkg-name (intern (string-upcase (format nil "ORG-AGENT.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(when (uiop:string-prefix-p "#+DEPENDS_ON:" (string-upcase clean-line))
|
||||
(setf dependencies (mapcar (lambda (s) (string-trim "[] " s)) (uiop:split-string (subseq clean-line 13) :separator '(#\Space)))))))
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond ((uiop:string-prefix-p "#+begin_src lisp" (string-downcase clean-line)) (setf in-lisp-block t))
|
||||
((uiop:string-prefix-p "#+end_src" (string-downcase clean-line)) (setf in-lisp-block nil))
|
||||
(in-lisp-block (setf lisp-code (concatenate 'string lisp-code line (string #\Newline)))))))
|
||||
(when (> (length lisp-code) 0)
|
||||
(kernel-log "KERNEL: Jailing skill '~a' in package ~a" skill-base-name pkg-name)
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl))))
|
||||
(do-external-symbols (sym (find-package :org-agent)) (shadowing-import sym new-pkg))))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(handler-case (eval (read-from-string (format nil "(progn ~a)" lisp-code)))
|
||||
(error (c) (kernel-log "READER ERROR in skill '~a': ~a~%" skill-base-name c))))))))
|
||||
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
(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)) (values t nil)))
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
#+end_src
|
||||
|
||||
* Daemon Runtime
|
||||
** Lifecycle & Loop
|
||||
#+begin_src lisp :tangle ../src/core.lisp
|
||||
(in-package :org-agent)
|
||||
|
||||
(defvar *system-logs* nil)
|
||||
(defvar *logs-lock* (bt:make-lock "kernel-logs-lock"))
|
||||
(defvar *max-log-history* 100)
|
||||
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bt:make-lock "kernel-telemetry-lock"))
|
||||
|
||||
(defun kernel-track-telemetry (skill-name duration status)
|
||||
(when skill-name (bt:with-lock-held (*telemetry-lock*)
|
||||
(let ((entry (or (gethash skill-name *skill-telemetry*) (list :executions 0 :total-time 0 :failures 0))))
|
||||
(incf (getf entry :executions)) (incf (getf entry :total-time) duration)
|
||||
(when (eq status :rejected) (incf (getf entry :failures))) (setf (gethash skill-name *skill-telemetry*) entry)))))
|
||||
|
||||
(defun kernel-log (fmt &rest args)
|
||||
(let ((msg (apply #'format nil fmt args)))
|
||||
(bt:with-lock-held (*logs-lock*) (push msg *system-logs*) (when (> (length *system-logs*) *max-log-history*) (setf *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||
(format t "~a~%" msg) (finish-output)))
|
||||
|
||||
(defvar *heartbeat-thread* nil)
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equal))
|
||||
(defun register-actuator (name fn)
|
||||
"Registers an actuator function. Actuators receive two arguments: (ACTION CONTEXT)."
|
||||
(setf (gethash name *actuator-registry*) fn))
|
||||
|
||||
(defun inject-stimulus (raw-message &key stream)
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
(sensor (getf payload :sensor))
|
||||
;; Force Chat and Delegation to be async
|
||||
(async-p (or (getf payload :async-p) (member sensor '(:chat-message :delegation :user-command)))))
|
||||
(when stream (setf (getf raw-message :reply-stream) stream))
|
||||
(if async-p (bt:make-thread (lambda () (restart-case (handler-bind ((error (lambda (c) (kernel-log "ASYNC ERROR: ~a" c) (invoke-restart 'skip-event))))
|
||||
(cognitive-loop raw-message)) (skip-event () nil))) :name "org-agent-async-task")
|
||||
(restart-case (handler-bind ((error (lambda (c) (kernel-log "SYSTEM ERROR: ~a" c) (invoke-restart 'skip-event)))) (cognitive-loop raw-message))
|
||||
(skip-event () (kernel-log "SYSTEM RECOVERY: Stimulus dropped.~%"))))))
|
||||
|
||||
(defun spawn-task (task-description &key (async-p t))
|
||||
(inject-stimulus `(:type :EVENT :payload (:sensor :delegation :query ,task-description :async-p ,async-p))))
|
||||
|
||||
(defun send-swarm-packet (target-url payload)
|
||||
(let* ((json-payload (cl-json:encode-json-to-string payload)) (headers '(("Content-Type" . "application/json"))))
|
||||
(handler-case (dex:post target-url :headers headers :content json-payload) (error (c) (kernel-log "SWARM ERROR: ~a" c) nil))))
|
||||
|
||||
(defun dispatch-action (action context)
|
||||
(when (and action (listp action))
|
||||
(let* ((target (or (ignore-errors (getf action :target)) :emacs)) (actuator-fn (gethash target *actuator-registry*)))
|
||||
(if actuator-fn (funcall actuator-fn action context) (kernel-log "DISPATCH ERROR: No actuator for ~a" target)))))
|
||||
|
||||
(defun execute-system-action (action context)
|
||||
(declare (ignore context))
|
||||
(let* ((payload (ignore-errors (getf action :payload))) (cmd (ignore-errors (getf payload :action))))
|
||||
(case cmd
|
||||
(:create-skill (let* ((filename (getf payload :filename)) (content (getf payload :content))
|
||||
(skills-dir (merge-pathnames "skills/" (asdf:system-source-directory :org-agent))) (full-path (merge-pathnames filename skills-dir)))
|
||||
(kernel-log "ACTUATOR [System] - Creating skill ~a..." filename)
|
||||
(with-open-file (out full-path :direction :output :if-exists :supersede) (write-string content out))
|
||||
(load-skill-from-org full-path)))
|
||||
(:set-cascade (setf *provider-cascade* (getf payload :cascade)))
|
||||
(:message (kernel-log "ACTUATOR [System] - ~a" (getf payload :text)))
|
||||
(t (kernel-log "ACTUATOR [System] - Unknown command ~s" cmd)))))
|
||||
|
||||
(defun cognitive-loop (raw-message)
|
||||
(let* ((start-time (get-internal-real-time))
|
||||
(perceive-fn (find-symbol "PERCEIVE" :org-agent))
|
||||
(context (if perceive-fn (funcall perceive-fn raw-message) raw-message))
|
||||
(skill (find-triggered-skill context))
|
||||
(skill-name (when skill (skill-name skill))))
|
||||
(snapshot-object-store)
|
||||
(let* ((proposed-action (think context)) (approved-action (decide proposed-action context))
|
||||
(status (if (and proposed-action (null approved-action)) :rejected :success))
|
||||
(duration (- (get-internal-real-time) start-time)))
|
||||
(when skill-name (kernel-track-telemetry skill-name duration status))
|
||||
(dispatch-action approved-action context))))
|
||||
|
||||
(defun perceive (raw-message)
|
||||
(let ((type (getf raw-message :type)) (payload (getf raw-message :payload)))
|
||||
(kernel-log "PERCEIVE: ~a (~a)" type (or (getf payload :sensor) "no-sensor"))
|
||||
(cond ((eq type :EVENT) (let ((sensor (getf payload :sensor)))
|
||||
(case sensor
|
||||
(:buffer-update (let ((ast (getf payload :ast))) (when ast (ingest-ast ast))))
|
||||
(:point-update (let ((element (getf payload :element))) (when element (ingest-ast element)))))))
|
||||
((eq type :RESPONSE) (kernel-log "ACT RESULT: ~a" (getf payload :status))))
|
||||
raw-message))
|
||||
|
||||
(defun start-heartbeat ()
|
||||
(let ((interval (or (ignore-errors (parse-integer (get-env "HEARTBEAT_INTERVAL") :junk-allowed t)) 60)))
|
||||
(setf *heartbeat-thread* (bt:make-thread (lambda () (loop (sleep interval) (kernel-log "KERNEL: Heartbeat pulse...")
|
||||
(inject-stimulus `(:type :EVENT :payload (:sensor :heartbeat :unix-time ,(get-universal-time)))))) :name "org-agent-heartbeat"))))
|
||||
|
||||
(defun stop-heartbeat () (when (and *heartbeat-thread* (bt:thread-alive-p *heartbeat-thread*)) (bt:destroy-thread *heartbeat-thread*) (setf *heartbeat-thread* nil)))
|
||||
|
||||
(defun load-all-skills ()
|
||||
"Scans the directory defined by SKILLS_DIR and hot-loads skills.
|
||||
Supports selective loading via SKILLS_WHITELIST environment variable."
|
||||
(let* ((env-path (uiop:getenv "SKILLS_DIR"))
|
||||
(whitelist-raw (uiop:getenv "SKILLS_WHITELIST"))
|
||||
(whitelist (when whitelist-raw (uiop:split-string whitelist-raw :separator '(#\,))))
|
||||
(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)))
|
||||
(if (and skills-dir (uiop:directory-exists-p skills-dir))
|
||||
(let ((files (uiop:directory-files skills-dir "org-skill-*.org")))
|
||||
(if files
|
||||
(dolist (file files)
|
||||
(let ((skill-name (pathname-name file)))
|
||||
(if (or (null whitelist) (member skill-name whitelist :test #'string-equal))
|
||||
(load-skill-from-org file)
|
||||
(kernel-log "KERNEL: Skipping skill ~a (Not in whitelist)" skill-name))))
|
||||
(kernel-log "KERNEL: No skills found in ~a" resolved-path)))
|
||||
(kernel-log "KERNEL ERROR: Skills directory not found or invalid path: ~a" skills-dir-str))))
|
||||
|
||||
(defvar *daemon-thread* nil) (defvar *daemon-socket* nil)
|
||||
(defun handle-client (stream)
|
||||
"Main loop for a single OACP client connection."
|
||||
(kernel-log "DAEMON: New client connected.~%")
|
||||
(unwind-protect
|
||||
(loop
|
||||
(handler-case
|
||||
(progn
|
||||
;; 1. Skip leading whitespace/newlines
|
||||
(loop for char = (peek-char nil stream nil :eof)
|
||||
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Return #\Tab)))
|
||||
do (read-char stream))
|
||||
|
||||
(let ((peek (peek-char nil stream nil :eof)))
|
||||
(if (eq peek :eof) (return))
|
||||
(let* ((len-prefix (make-string 6)))
|
||||
;; 2. Read the 6-character length prefix
|
||||
(unless (read-sequence len-prefix stream)
|
||||
(return))
|
||||
(let* ((len (parse-integer len-prefix :radix 16))
|
||||
(msg-payload (make-string len)))
|
||||
;; 3. Read the actual message payload
|
||||
(unless (read-sequence msg-payload stream)
|
||||
(return))
|
||||
;; 4. Parse and process
|
||||
(let ((msg (read-from-string msg-payload)))
|
||||
(kernel-log "DAEMON: Received stimulus (~a characters)~%" len)
|
||||
(inject-stimulus msg :stream stream))))))
|
||||
(error (c)
|
||||
(kernel-log "DAEMON CLIENT ERROR: ~a~%" c)
|
||||
(return))))
|
||||
(kernel-log "DAEMON: Client disconnected.~%")
|
||||
(ignore-errors (close stream))))
|
||||
|
||||
(defun start-daemon (&key port)
|
||||
(let* ((env-host (uiop:getenv "DAEMON_HOST")) (env-port (uiop:getenv "ORG_AGENT_DAEMON_PORT"))
|
||||
(listen-host (if env-host (string-trim " \"'" env-host) "127.0.0.1"))
|
||||
(listen-port (or (or port (when env-port (ignore-errors (parse-integer (string-trim " \"'" env-port) :junk-allowed t)))) 9105)))
|
||||
(register-actuator :system #'execute-system-action)
|
||||
(register-actuator :emacs (lambda (action context)
|
||||
(declare (ignore context))
|
||||
(kernel-log "ACTUATOR [Emacs] - Action: ~a~%" action)))
|
||||
(start-heartbeat)
|
||||
(kernel-log "DAEMON: Binding to ~a:~a..." listen-host listen-port)
|
||||
(setf *daemon-socket* (usocket:socket-listen listen-host listen-port :reuse-address t))
|
||||
(setf *daemon-thread* (bt:make-thread (lambda () (unwind-protect (loop (handler-case (let ((client-socket (usocket:socket-accept *daemon-socket*)))
|
||||
(bt:make-thread (lambda () (handle-client (usocket:socket-stream client-socket))) :name "org-agent-client-handler"))
|
||||
(error (c) (kernel-log "DAEMON ERROR: ~a" c) (sleep 0.1))))
|
||||
(usocket:socket-close *daemon-socket*))) :name "org-agent-tcp-listener"))
|
||||
(kernel-log "==================================================~% org-agent Kernel Booted Successfully.~% Daemon Listening: ~a:~a~%==================================================" listen-host listen-port)
|
||||
(load-all-skills)))
|
||||
|
||||
(defun stop-daemon () (stop-heartbeat) (when *daemon-socket* (usocket:socket-close *daemon-socket*) (setf *daemon-socket* nil)) (kernel-log "org-agent Kernel stopped.~%"))
|
||||
|
||||
(defun main ()
|
||||
"The entry point for the compiled standalone binary."
|
||||
(let* ((home (uiop:getenv "HOME"))
|
||||
(env-file (uiop:merge-pathnames* ".local/share/org-agent/.env" (uiop:ensure-directory-pathname home))))
|
||||
(if (uiop:file-exists-p env-file)
|
||||
(progn
|
||||
(format t "KERNEL: Loading environment from ~a~%" env-file)
|
||||
(cl-dotenv:load-env env-file))
|
||||
(format t "KERNEL ERROR: .env not found at ~a~%" env-file)))
|
||||
(start-daemon)
|
||||
;; Keep the process alive.
|
||||
(loop (sleep 3600)))
|
||||
#+end_src
|
||||
|
||||
* Long-Term Vision: Orders of Autonomy
|
||||
|
||||
The development of =org-agent= follows distinct orders of autonomy, progressing from a basic assistant to a fully sovereign entity.
|
||||
|
||||
** Order 1: The Reactive Kernel (Phase 1 & 2)
|
||||
The agent acts as a strict "Delegator." It requires human stimulus to trigger the Cognitive Loop. Capabilities (Skills) are expanded, but the agent only speaks when spoken to.
|
||||
|
||||
** Order 2: The Self-Editing Kernel (Phase 3 - Current)
|
||||
The agent achieves introspection. It can "perceive pain" (errors) via system logs and trigger a `skill-self-fix` loop to rewrite its own source code, hot-reloading the changes. It proactively maintains the system.
|
||||
The agent achieves introspection. It can "perceive pain" (errors) via system logs and trigger a =skill-self-fix= loop to rewrite its own source code, hot-reloading the changes. It proactively maintains the system.
|
||||
|
||||
** Order 3: The Sovereign Architect (Phase 4+)
|
||||
The agent transitions to full autonomy. It maintains the Consensus Loop entirely, identifying structural decay in the Memex, drafting its own PRDs, writing code, executing Chaos testing, and committing the final result without human intervention (unless authorization gates are explicitly set).
|
||||
|
||||
BIN
org-agent-server
BIN
org-agent-server
Binary file not shown.
@@ -10,6 +10,7 @@
|
||||
:components ((:file "package")
|
||||
(:file "protocol")
|
||||
(:file "object-store")
|
||||
(:file "context")
|
||||
(:file "embedding")
|
||||
(:file "skills")
|
||||
(:file "neuro")
|
||||
|
||||
109
src/context.lisp
109
src/context.lisp
@@ -1,134 +1,59 @@
|
||||
(in-package :org-agent)
|
||||
|
||||
;;; ============================================================================
|
||||
;;; Context API (System 1 Peripheral Vision)
|
||||
;;; ============================================================================
|
||||
;;; These functions provide the 'peripheral vision' for the LLM.
|
||||
;;; When building a prompt, a skill can call these functions to gather
|
||||
;;; relevant facts from the Object Store, preventing 'tunnel vision'.
|
||||
|
||||
(defun context-query-store (&key tag todo-state type)
|
||||
"A high-level search engine for the Object Store.
|
||||
TAG: String to search for in the :TAGS property.
|
||||
TODO-STATE: The string state (e.g., 'TODO', 'DONE', 'WAITING').
|
||||
TYPE: The keyword type (e.g., :HEADLINE).
|
||||
|
||||
Returns a list of org-object structs that satisfy ALL provided criteria."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let* ((attrs (org-object-attributes obj))
|
||||
(obj-type (org-object-type obj))
|
||||
(tags (getf attrs :TAGS))
|
||||
(state (getf attrs :TODO-STATE))
|
||||
(match t))
|
||||
;; Filter by Type
|
||||
(when (and type (not (eq obj-type type))) (setf match nil))
|
||||
|
||||
;; Filter by Tag (Org tags are often stored as a colon-delimited string like ':work:urgent:')
|
||||
(when tag
|
||||
(let ((tags-str (format nil "~a" tags)))
|
||||
(unless (search tag tags-str :test #'string-equal)
|
||||
(setf match nil))))
|
||||
|
||||
;; Filter by TODO State
|
||||
(let* ((attrs (org-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t))
|
||||
(when (and type (not (eq (org-object-type obj) type))) (setf match nil))
|
||||
(when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil)))
|
||||
(when (and todo-state (not (equal state todo-state))) (setf match nil))
|
||||
|
||||
(when match (push obj results))))
|
||||
*object-store*)
|
||||
results))
|
||||
|
||||
(defun context-get-active-projects ()
|
||||
"Retrieves all headlines tagged with 'project' that are not yet complete.
|
||||
This allows the agent to understand what the user is currently working on."
|
||||
(let ((projects (context-query-store :tag "project" :type :HEADLINE)))
|
||||
(remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
projects)))
|
||||
(remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(context-query-store :tag "project" :type :HEADLINE)))
|
||||
|
||||
(defun context-get-recent-completed-tasks ()
|
||||
"Retrieves tasks that have been successfully finished.
|
||||
Used to give the LLM context about the user's 'momentum' and recent wins."
|
||||
(context-query-store :todo-state "DONE" :type :HEADLINE))
|
||||
|
||||
;;; ============================================================================
|
||||
;;; Introspection API (Self-Awareness)
|
||||
;;; ============================================================================
|
||||
;;; These functions allow the agent to see its own internal configuration,
|
||||
;;; such as its skill priorities and source code. This is critical for
|
||||
;;; Phase 3 (Self-Editing) and autonomous priority negotiation.
|
||||
(defun context-get-recent-completed-tasks () (context-query-store :todo-state "DONE" :type :HEADLINE))
|
||||
|
||||
(defun context-list-all-skills ()
|
||||
"Returns a list of plists for all currently registered skills.
|
||||
Each plist contains :name, :priority, and :dependencies.
|
||||
This allows System 1 to understand the current 'Skill Graph'."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(push (list :name (skill-name skill)
|
||||
:priority (skill-priority skill)
|
||||
:dependencies (skill-dependencies skill))
|
||||
results))
|
||||
(push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results))
|
||||
*skills-registry*)
|
||||
(sort results #'> :key (lambda (x) (getf x :priority)))))
|
||||
|
||||
(defun context-get-skill-source (skill-name)
|
||||
"Reads the raw Org-mode source code of a specific skill.
|
||||
Returns the file content as a string, or NIL if the file is missing."
|
||||
(let* ((filename (format nil "~a.org" skill-name))
|
||||
(skills-dir (merge-pathnames "skills/" (asdf:system-source-directory :org-agent)))
|
||||
(full-path (merge-pathnames filename skills-dir)))
|
||||
(if (uiop:file-exists-p full-path)
|
||||
(uiop:read-file-string full-path)
|
||||
nil)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
|
||||
(defun context-get-system-logs (&optional (limit 20))
|
||||
"Returns the most recent N lines from the kernel's execution history.
|
||||
Allows the agent to 'perceive pain' (errors/rejections) and trigger self-repair."
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(let ((count (min limit (length *system-logs*))))
|
||||
(subseq *system-logs* 0 count))))
|
||||
(let ((count (min limit (length *system-logs*)))) (subseq *system-logs* 0 count))))
|
||||
|
||||
(defun context-get-skill-telemetry (skill-name)
|
||||
"Returns performance metrics for a specific skill.
|
||||
Returns a plist with :executions, :total-time, and :failures."
|
||||
(bt:with-lock-held (*telemetry-lock*)
|
||||
(gethash (string-downcase skill-name) *skill-telemetry*)))
|
||||
(bt:with-lock-held (*telemetry-lock*) (gethash (string-downcase skill-name) *skill-telemetry*)))
|
||||
|
||||
(defun context-filter-sparse-tree (ast predicate)
|
||||
"Recursively prunes an Org AST, keeping only nodes that match PREDICATE
|
||||
and their parent hierarchies. Reduces token waste by removing noise."
|
||||
(if (listp ast)
|
||||
(let* ((type (getf ast :type))
|
||||
(contents (getf ast :contents))
|
||||
;; Recursively filter children
|
||||
(filtered-contents
|
||||
(remove-if #'null
|
||||
(mapcar (lambda (c) (context-filter-sparse-tree c predicate))
|
||||
contents))))
|
||||
|
||||
(if (or (funcall predicate ast)
|
||||
(not (null filtered-contents)))
|
||||
;; If this node matches OR has matching children, keep it
|
||||
(let ((new-ast (copy-list ast)))
|
||||
(setf (getf new-ast :contents) filtered-contents)
|
||||
new-ast)
|
||||
;; Otherwise, prune this entire branch
|
||||
(let* ((contents (getf ast :contents))
|
||||
(filtered-contents (remove-if #'null (mapcar (lambda (c) (context-filter-sparse-tree c predicate)) contents))))
|
||||
(if (or (funcall predicate ast) (not (null filtered-contents)))
|
||||
(let ((new-ast (copy-list ast))) (setf (getf new-ast :contents) filtered-contents) new-ast)
|
||||
nil))
|
||||
;; If it's a string (leaf content), keep it if the predicate says so,
|
||||
;; but usually we keep it if the parent headline matches.
|
||||
nil))
|
||||
|
||||
(defun context-resolve-path (path-string)
|
||||
"Resolves environment variables in a path string (e.g., '$PROJECTS_DIR/my-proj').
|
||||
This ensures project links remain valid even if base directories are moved."
|
||||
(if (and (stringp path-string) (uiop:string-prefix-p "$" path-string))
|
||||
(let* ((parts (uiop:split-string path-string :separator '(#\/)))
|
||||
(var-name (subseq (car parts) 1)) ; Strip the '$'
|
||||
(var-val (org-agent::get-env var-name))
|
||||
(var-name (subseq (car parts) 1)) (var-val (uiop:getenv var-name))
|
||||
(remaining (cl:reduce (lambda (a b) (format nil "~a/~a" a b)) (cdr parts))))
|
||||
(if var-val
|
||||
;; Strip any extra quotes that cl-dotenv might have preserved
|
||||
(let ((clean-val (string-trim '(#\" #\Space) var-val)))
|
||||
(format nil "~a/~a" (string-right-trim "/" clean-val) remaining))
|
||||
(if var-val (let ((clean-val (string-trim '(#\" #\Space) var-val)))
|
||||
(format nil "~a/~a" (string-right-trim "/" clean-val) remaining))
|
||||
path-string))
|
||||
path-string))
|
||||
|
||||
387
src/core.lisp
387
src/core.lisp
@@ -1,294 +1,177 @@
|
||||
(in-package :org-agent)
|
||||
|
||||
;;; ============================================================================
|
||||
;;; Internal Logging (The Kernel's Senses)
|
||||
;;; ============================================================================
|
||||
|
||||
(defvar *system-logs* nil
|
||||
"A thread-safe circular buffer of recent kernel activity.")
|
||||
(defvar *system-logs* nil)
|
||||
(defvar *logs-lock* (bt:make-lock "kernel-logs-lock"))
|
||||
(defvar *max-log-history* 100
|
||||
"Maximum number of log entries to retain in memory.")
|
||||
|
||||
(defvar *skill-telemetry* (make-hash-table :test 'equal)
|
||||
"Thread-safe storage for skill performance metrics.")
|
||||
(defvar *max-log-history* 100)
|
||||
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bt:make-lock "kernel-telemetry-lock"))
|
||||
|
||||
(defun kernel-track-telemetry (skill-name duration status)
|
||||
"Records the execution time and result status of a skill."
|
||||
(when skill-name
|
||||
(bt:with-lock-held (*telemetry-lock*)
|
||||
(let ((entry (or (gethash skill-name *skill-telemetry*)
|
||||
(list :executions 0 :total-time 0 :failures 0))))
|
||||
(incf (getf entry :executions))
|
||||
(incf (getf entry :total-time) duration)
|
||||
(when (eq status :rejected) (incf (getf entry :failures)))
|
||||
(setf (gethash skill-name *skill-telemetry*) entry)))))
|
||||
(when skill-name (bt:with-lock-held (*telemetry-lock*)
|
||||
(let ((entry (or (gethash skill-name *skill-telemetry*) (list :executions 0 :total-time 0 :failures 0))))
|
||||
(incf (getf entry :executions)) (incf (getf entry :total-time) duration)
|
||||
(when (eq status :rejected) (incf (getf entry :failures))) (setf (gethash skill-name *skill-telemetry*) entry)))))
|
||||
|
||||
(defun kernel-log (fmt &rest args)
|
||||
"Logs a message to both standard output and the internal circular buffer."
|
||||
(let ((msg (apply #'format nil fmt args)))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(push msg *system-logs*)
|
||||
;; Enforce maximum history length
|
||||
(when (> (length *system-logs*) *max-log-history*)
|
||||
(setf *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||
;; Mirror to stdout for Docker/Console monitoring
|
||||
(format t "~a~%" msg)
|
||||
(finish-output)))
|
||||
(bt:with-lock-held (*logs-lock*) (push msg *system-logs*) (when (> (length *system-logs*) *max-log-history*) (setf *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||
(format t "~a~%" msg) (finish-output)))
|
||||
|
||||
;;; ============================================================================
|
||||
;;; The Autonomic Heartbeat
|
||||
;;; ============================================================================
|
||||
|
||||
(defvar *heartbeat-thread* nil
|
||||
"The background thread that provides temporal awareness.")
|
||||
|
||||
;;; ============================================================================
|
||||
;;; The Actuator API (Event Bus)
|
||||
;;; ============================================================================
|
||||
;;; The Core Daemon acts as a decoupled Event Bus. Sensors (like Emacs or
|
||||
;;; Cron) inject stimuli, and Actuators (like the Emacs Bridge) execute
|
||||
;;; the resulting decisions.
|
||||
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equal)
|
||||
"Registry of loaded actuators. Key is a keyword (e.g., :emacs),
|
||||
value is a function that executes an action plist.")
|
||||
|
||||
(defun register-actuator (name fn)
|
||||
"Adds a new actuator function to the system.
|
||||
Called by I/O skills (like sk-emacs-bridge) during startup."
|
||||
(defvar *heartbeat-thread* nil)
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equal))
|
||||
(defun register-actuator (name fn)
|
||||
"Registers an actuator function. Actuators receive two arguments: (ACTION CONTEXT)."
|
||||
(setf (gethash name *actuator-registry*) fn))
|
||||
|
||||
(defun inject-stimulus (raw-message)
|
||||
"The entry point for all external data. This triggers the Cognitive Loop.
|
||||
|
||||
It implements 'Fault-Tolerant Reasoning' using Lisp restarts. If a
|
||||
skill crashes, the daemon survives and moves to the next event."
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
(async-p (getf payload :async-p)))
|
||||
(if async-p
|
||||
(bt:make-thread (lambda ()
|
||||
(restart-case
|
||||
(handler-bind ((error (lambda (c)
|
||||
(kernel-log "ASYNC SYSTEM ERROR: ~a~%" c)
|
||||
(invoke-restart 'skip-event))))
|
||||
(cognitive-loop raw-message))
|
||||
(skip-event () nil)))
|
||||
:name "org-agent-async-task")
|
||||
(restart-case
|
||||
(handler-bind ((error (lambda (c)
|
||||
(kernel-log "SYSTEM ERROR (inject-stimulus): ~a~%" c)
|
||||
;; Log the error and invoke the skip-event restart
|
||||
(invoke-restart 'skip-event))))
|
||||
(cognitive-loop raw-message))
|
||||
(skip-event ()
|
||||
(kernel-log "SYSTEM RECOVERY: Stimulus dropped to prevent kernel panic.~%"))))))
|
||||
(defun inject-stimulus (raw-message &key stream)
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
(sensor (getf payload :sensor))
|
||||
;; Force Chat and Delegation to be async
|
||||
(async-p (or (getf payload :async-p) (member sensor '(:chat-message :delegation :user-command)))))
|
||||
(when stream (setf (getf raw-message :reply-stream) stream))
|
||||
(if async-p (bt:make-thread (lambda () (restart-case (handler-bind ((error (lambda (c) (kernel-log "ASYNC ERROR: ~a" c) (invoke-restart 'skip-event))))
|
||||
(cognitive-loop raw-message)) (skip-event () nil))) :name "org-agent-async-task")
|
||||
(restart-case (handler-bind ((error (lambda (c) (kernel-log "SYSTEM ERROR: ~a" c) (invoke-restart 'skip-event)))) (cognitive-loop raw-message))
|
||||
(skip-event () (kernel-log "SYSTEM RECOVERY: Stimulus dropped.~%"))))))
|
||||
|
||||
(defun spawn-task (task-description &key (async-p t))
|
||||
"A programmatic way for skills to delegate sub-tasks to the kernel.
|
||||
If ASYNC-P is true, it spawns a new thread, enabling 'Swarm' orchestration."
|
||||
(let ((msg `(:type :EVENT :payload (:sensor :delegation :query ,task-description :async-p ,async-p))))
|
||||
(inject-stimulus msg)))
|
||||
(inject-stimulus `(:type :EVENT :payload (:sensor :delegation :query ,task-description :async-p ,async-p))))
|
||||
|
||||
(defun send-swarm-packet (target-url payload)
|
||||
"Serializes a cognitive context and dispatches it to a remote org-agent.
|
||||
Enables federated, cross-machine swarming."
|
||||
(let* ((json-payload (cl-json:encode-json-to-string payload))
|
||||
(headers '(("Content-Type" . "application/json"))))
|
||||
(kernel-log "SWARM - Dispatching packet to ~a..." target-url)
|
||||
(handler-case
|
||||
(dex:post target-url :headers headers :content json-payload)
|
||||
(error (c)
|
||||
(kernel-log "SWARM ERROR - Failed to reach remote instance: ~a" c)
|
||||
nil))))
|
||||
(let* ((json-payload (cl-json:encode-json-to-string payload)) (headers '(("Content-Type" . "application/json"))))
|
||||
(handler-case (dex:post target-url :headers headers :content json-payload) (error (c) (kernel-log "SWARM ERROR: ~a" c) nil))))
|
||||
|
||||
(defun dispatch-action (action context)
|
||||
(when (and action (listp action))
|
||||
(let* ((target (or (ignore-errors (getf action :target)) :emacs)) (actuator-fn (gethash target *actuator-registry*)))
|
||||
(if actuator-fn (funcall actuator-fn action context) (kernel-log "DISPATCH ERROR: No actuator for ~a" target)))))
|
||||
|
||||
(defun dispatch-action (action)
|
||||
"Routes an approved action intent to the correct physical actuator."
|
||||
(when action
|
||||
(let* ((payload (getf action :payload))
|
||||
;; We default to :emacs for backward compatibility.
|
||||
(target (or (getf action :target) :emacs))
|
||||
(actuator-fn (gethash target *actuator-registry*)))
|
||||
(if actuator-fn
|
||||
(funcall actuator-fn action)
|
||||
(kernel-log "DISPATCH ERROR: No actuator registered for target ~a~%" target)))))
|
||||
|
||||
;;; ============================================================================
|
||||
;;; System Actuator (Self-Editing)
|
||||
;;; ============================================================================
|
||||
|
||||
(defun execute-system-action (action)
|
||||
"Handles internal kernel operations like skill creation and hot-reloading."
|
||||
(let* ((payload (getf action :payload))
|
||||
(cmd (getf payload :action)))
|
||||
(defun execute-system-action (action context)
|
||||
(declare (ignore context))
|
||||
(let* ((payload (ignore-errors (getf action :payload))) (cmd (ignore-errors (getf payload :action))))
|
||||
(case cmd
|
||||
(:create-skill
|
||||
(let* ((filename (getf payload :filename))
|
||||
(content (getf payload :content))
|
||||
(skills-dir (merge-pathnames "skills/" (asdf:system-source-directory :org-agent)))
|
||||
(full-path (merge-pathnames filename skills-dir)))
|
||||
(kernel-log "ACTUATOR [System] - Creating skill ~a..." filename)
|
||||
(with-open-file (out full-path :direction :output :if-exists :supersede)
|
||||
(write-string content out))
|
||||
;; Hot-Reload immediately
|
||||
(load-skill-from-org full-path)
|
||||
(kernel-log "ACTUATOR [System] - Skill ~a hot-reloaded." filename)))
|
||||
(:set-cascade
|
||||
(let ((new-cascade (getf payload :cascade)))
|
||||
(setf *provider-cascade* new-cascade)
|
||||
(kernel-log "ACTUATOR [System] - LLM Cascade updated to: ~a" new-cascade)))
|
||||
(:set-priority
|
||||
(let* ((name (string-downcase (format nil "~a" (getf payload :skill))))
|
||||
(val (getf payload :priority))
|
||||
(skill (gethash name *skills-registry*)))
|
||||
(if skill
|
||||
(progn
|
||||
(setf (skill-priority skill) val)
|
||||
(kernel-log "ACTUATOR [System] - Set priority of ~a to ~a" name val))
|
||||
(kernel-log "ACTUATOR [System] ERROR - Skill ~a not found" name))))
|
||||
(:auth-google-code
|
||||
(let ((code (getf payload :code)))
|
||||
(kernel-log "ACTUATOR [System] - Received Google OAuth code. Exchanging...")
|
||||
;; We call the function in the skill package.
|
||||
;; Note: In a production kernel, we would use a more robust hook system.
|
||||
(if (uiop:symbol-call :org-agent.skills.org-skill-auth-google-oauth :auth-google-receive-code code)
|
||||
(kernel-log "ACTUATOR [System] - Google OAuth exchange successful.")
|
||||
(kernel-log "ACTUATOR [System] - Google OAuth exchange FAILED."))))
|
||||
(t (kernel-log "ACTUATOR [System] - Unknown command ~a" cmd)))))
|
||||
|
||||
;;; ============================================================================
|
||||
;;; The Cognitive Loop (OODA)
|
||||
;;; ============================================================================
|
||||
;;; This is the pure, deterministic pipeline of the Lisp Machine.
|
||||
;;; It coordinates the transition from Perception to Action.
|
||||
(:create-skill (let* ((filename (getf payload :filename)) (content (getf payload :content))
|
||||
(skills-dir (merge-pathnames "skills/" (asdf:system-source-directory :org-agent))) (full-path (merge-pathnames filename skills-dir)))
|
||||
(kernel-log "ACTUATOR [System] - Creating skill ~a..." filename)
|
||||
(with-open-file (out full-path :direction :output :if-exists :supersede) (write-string content out))
|
||||
(load-skill-from-org full-path)))
|
||||
(:set-cascade (setf *provider-cascade* (getf payload :cascade)))
|
||||
(:message (kernel-log "ACTUATOR [System] - ~a" (getf payload :text)))
|
||||
(t (kernel-log "ACTUATOR [System] - Unknown command ~s" cmd)))))
|
||||
|
||||
(defun cognitive-loop (raw-message)
|
||||
"Orchestrates the four stages of cognition with performance tracking."
|
||||
(let* ((start-time (get-internal-real-time))
|
||||
(context (perceive raw-message))
|
||||
(skill (find-triggered-skill context))
|
||||
(let* ((start-time (get-internal-real-time))
|
||||
(perceive-fn (find-symbol "PERCEIVE" :org-agent))
|
||||
(context (if perceive-fn (funcall perceive-fn raw-message) raw-message))
|
||||
(skill (find-triggered-skill context))
|
||||
(skill-name (when skill (skill-name skill))))
|
||||
|
||||
;; SOTA: Snapshot the memory state BEFORE thinking to enable rollback
|
||||
(snapshot-object-store)
|
||||
|
||||
(let* ((proposed-action (think context))
|
||||
(approved-action (decide proposed-action context))
|
||||
(let* ((proposed-action (think context)) (approved-action (decide proposed-action context))
|
||||
(status (if (and proposed-action (null approved-action)) :rejected :success))
|
||||
(end-time (get-internal-real-time))
|
||||
(duration (- end-time start-time)))
|
||||
|
||||
;; Record telemetry for the engaged skill
|
||||
(when skill-name
|
||||
(kernel-track-telemetry skill-name duration status))
|
||||
|
||||
(dispatch-action approved-action))))
|
||||
(duration (- (get-internal-real-time) start-time)))
|
||||
(when skill-name (kernel-track-telemetry skill-name duration status))
|
||||
(dispatch-action approved-action context))))
|
||||
|
||||
(defun perceive (raw-message)
|
||||
"Updates the Object Store based on incoming stimulus and returns the context."
|
||||
(let ((type (getf raw-message :type))
|
||||
(payload (getf raw-message :payload)))
|
||||
(let ((type (getf raw-message :type)) (payload (getf raw-message :payload)))
|
||||
(kernel-log "PERCEIVE: ~a (~a)" type (or (getf payload :sensor) "no-sensor"))
|
||||
(cond
|
||||
((eq type :EVENT)
|
||||
(let ((sensor (getf payload :sensor)))
|
||||
(case sensor
|
||||
(:buffer-update
|
||||
(let ((ast (getf payload :ast)))
|
||||
(when ast (ingest-ast ast))))
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element (ingest-ast element))))
|
||||
;; Ensure we don't return NIL for these
|
||||
(:user-command t)
|
||||
(:heartbeat t)
|
||||
(:chat-message t))))
|
||||
((eq type :RESPONSE)
|
||||
(kernel-log "ACT RESULT: ~a" (getf payload :status))))
|
||||
|
||||
;; ALWAYS return the raw message as the context base
|
||||
(cond ((eq type :EVENT) (let ((sensor (getf payload :sensor)))
|
||||
(case sensor
|
||||
(:buffer-update (let ((ast (getf payload :ast))) (when ast (ingest-ast ast))))
|
||||
(:point-update (let ((element (getf payload :element))) (when element (ingest-ast element)))))))
|
||||
((eq type :RESPONSE) (kernel-log "ACT RESULT: ~a" (getf payload :status))))
|
||||
raw-message))
|
||||
|
||||
(defun dispatch-action (action)
|
||||
"Sends an approved action to the appropriate actuator."
|
||||
(when (and action (not (eq action :rejected)))
|
||||
(let ((target (getf action :target)))
|
||||
(kernel-log "DISPATCH: Target ~a" target)
|
||||
(let ((actuator (gethash target *actuators*)))
|
||||
(if actuator
|
||||
(funcall actuator action)
|
||||
(kernel-log "ERROR: No actuator registered for ~a" target))))))
|
||||
|
||||
;;; ============================================================================
|
||||
;;; Daemon Lifecycle Management
|
||||
;;; ============================================================================
|
||||
|
||||
(defun start-heartbeat ()
|
||||
"Spawns the background pulse thread.
|
||||
Interval is controlled via HEARTBEAT_INTERVAL in .env."
|
||||
(let* ((env-interval (uiop:getenv "HEARTBEAT_INTERVAL"))
|
||||
(interval (if env-interval (parse-integer env-interval :junk-allowed t) 60)))
|
||||
(setf *heartbeat-thread*
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(sleep interval)
|
||||
(kernel-log "KERNEL: Heartbeat pulse...~%")
|
||||
(let* ((unix-time (get-universal-time))
|
||||
;; Inject a synthetic temporal event into the Event Bus.
|
||||
(heartbeat-msg `(:type :EVENT :payload (:sensor :heartbeat :unix-time ,unix-time))))
|
||||
(inject-stimulus heartbeat-msg))))
|
||||
:name "org-agent-heartbeat"))))
|
||||
(let ((interval (or (ignore-errors (parse-integer (get-env "HEARTBEAT_INTERVAL") :junk-allowed t)) 60)))
|
||||
(setf *heartbeat-thread* (bt:make-thread (lambda () (loop (sleep interval) (kernel-log "KERNEL: Heartbeat pulse...")
|
||||
(inject-stimulus `(:type :EVENT :payload (:sensor :heartbeat :unix-time ,(get-universal-time)))))) :name "org-agent-heartbeat"))))
|
||||
|
||||
(defun stop-heartbeat ()
|
||||
"Gracefully terminates the pulse thread."
|
||||
(when (and *heartbeat-thread* (bt:thread-alive-p *heartbeat-thread*))
|
||||
(bt:destroy-thread *heartbeat-thread*)
|
||||
(setf *heartbeat-thread* nil)))
|
||||
(defun stop-heartbeat () (when (and *heartbeat-thread* (bt:thread-alive-p *heartbeat-thread*)) (bt:destroy-thread *heartbeat-thread*) (setf *heartbeat-thread* nil)))
|
||||
|
||||
(defun load-all-skills ()
|
||||
"Scans the directory defined by SKILLS_DIR (defaults to notes) and hot-loads all skills.
|
||||
This is where the daemon acquires its intelligence, now unified with the Atomic Notes (Zettelkasten)."
|
||||
"Scans the directory defined by SKILLS_DIR and hot-loads skills.
|
||||
Supports selective loading via SKILLS_WHITELIST environment variable."
|
||||
(let* ((env-path (uiop:getenv "SKILLS_DIR"))
|
||||
(memex-dir (uiop:getenv "MEMEX_DIR"))
|
||||
(skills-dir (cond
|
||||
(env-path (uiop:ensure-directory-pathname env-path))
|
||||
(memex-dir (merge-pathnames "notes/" (uiop:ensure-directory-pathname memex-dir)))
|
||||
(t (merge-pathnames "notes/" (uiop:ensure-directory-pathname (uiop:native-namestring "~/memex/")))))))
|
||||
(if (uiop:directory-exists-p skills-dir)
|
||||
(progn
|
||||
(kernel-log "KERNEL: Loading skills from consolidated Atomic Notes (Zettelkasten): ~a" (uiop:native-namestring skills-dir))
|
||||
(let ((files (uiop:directory-files skills-dir "org-skill-*.org")))
|
||||
(if files
|
||||
(dolist (file files)
|
||||
(load-skill-from-org file))
|
||||
(kernel-log "KERNEL: No skills found matching 'org-skill-*.org' in ~a" (uiop:native-namestring skills-dir)))))
|
||||
(kernel-log "KERNEL ERROR: Skills directory not found at ~a" (uiop:native-namestring skills-dir)))))
|
||||
(whitelist-raw (uiop:getenv "SKILLS_WHITELIST"))
|
||||
(whitelist (when whitelist-raw (uiop:split-string whitelist-raw :separator '(#\,))))
|
||||
(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)))
|
||||
(if (and skills-dir (uiop:directory-exists-p skills-dir))
|
||||
(let ((files (uiop:directory-files skills-dir "org-skill-*.org")))
|
||||
(if files
|
||||
(dolist (file files)
|
||||
(let ((skill-name (pathname-name file)))
|
||||
(if (or (null whitelist) (member skill-name whitelist :test #'string-equal))
|
||||
(load-skill-from-org file)
|
||||
(kernel-log "KERNEL: Skipping skill ~a (Not in whitelist)" skill-name))))
|
||||
(kernel-log "KERNEL: No skills found in ~a" resolved-path)))
|
||||
(kernel-log "KERNEL ERROR: Skills directory not found or invalid path: ~a" skills-dir-str))))
|
||||
|
||||
(defun start-daemon (&key (port 9105))
|
||||
"Boots the Neurosymbolic Kernel.
|
||||
1. Loads skills.
|
||||
2. Starts the heartbeat.
|
||||
3. Becomes ready to receive stimuli."
|
||||
(declare (ignore port))
|
||||
(register-actuator :system #'execute-system-action)
|
||||
(load-all-skills)
|
||||
(start-heartbeat)
|
||||
(kernel-log "==================================================~%")
|
||||
(kernel-log " org-agent Kernel Booted Successfully. ~%")
|
||||
(kernel-log " Event Bus: ACTIVE ~%")
|
||||
(kernel-log "==================================================~%"))
|
||||
(defvar *daemon-thread* nil) (defvar *daemon-socket* nil)
|
||||
(defun handle-client (stream)
|
||||
"Main loop for a single OACP client connection."
|
||||
(kernel-log "DAEMON: New client connected.~%")
|
||||
(unwind-protect
|
||||
(loop
|
||||
(handler-case
|
||||
(progn
|
||||
;; 1. Skip leading whitespace/newlines
|
||||
(loop for char = (peek-char nil stream nil :eof)
|
||||
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Return #\Tab)))
|
||||
do (read-char stream))
|
||||
|
||||
(let ((peek (peek-char nil stream nil :eof)))
|
||||
(if (eq peek :eof) (return))
|
||||
(let* ((len-prefix (make-string 6)))
|
||||
;; 2. Read the 6-character length prefix
|
||||
(unless (read-sequence len-prefix stream)
|
||||
(return))
|
||||
(let* ((len (parse-integer len-prefix :radix 16))
|
||||
(msg-payload (make-string len)))
|
||||
;; 3. Read the actual message payload
|
||||
(unless (read-sequence msg-payload stream)
|
||||
(return))
|
||||
;; 4. Parse and process
|
||||
(let ((msg (read-from-string msg-payload)))
|
||||
(kernel-log "DAEMON: Received stimulus (~a characters)~%" len)
|
||||
(inject-stimulus msg :stream stream))))))
|
||||
(error (c)
|
||||
(kernel-log "DAEMON CLIENT ERROR: ~a~%" c)
|
||||
(return))))
|
||||
(kernel-log "DAEMON: Client disconnected.~%")
|
||||
(ignore-errors (close stream))))
|
||||
|
||||
(defun stop-daemon ()
|
||||
"Shutdown the kernel and all background threads."
|
||||
(stop-heartbeat)
|
||||
(kernel-log "org-agent Kernel stopped.~%"))
|
||||
(defun start-daemon (&key port)
|
||||
(let* ((env-host (uiop:getenv "DAEMON_HOST")) (env-port (uiop:getenv "ORG_AGENT_DAEMON_PORT"))
|
||||
(listen-host (if env-host (string-trim " \"'" env-host) "127.0.0.1"))
|
||||
(listen-port (or (or port (when env-port (ignore-errors (parse-integer (string-trim " \"'" env-port) :junk-allowed t)))) 9105)))
|
||||
(register-actuator :system #'execute-system-action)
|
||||
(register-actuator :emacs (lambda (action context)
|
||||
(declare (ignore context))
|
||||
(kernel-log "ACTUATOR [Emacs] - Action: ~a~%" action)))
|
||||
(start-heartbeat)
|
||||
(kernel-log "DAEMON: Binding to ~a:~a..." listen-host listen-port)
|
||||
(setf *daemon-socket* (usocket:socket-listen listen-host listen-port :reuse-address t))
|
||||
(setf *daemon-thread* (bt:make-thread (lambda () (unwind-protect (loop (handler-case (let ((client-socket (usocket:socket-accept *daemon-socket*)))
|
||||
(bt:make-thread (lambda () (handle-client (usocket:socket-stream client-socket))) :name "org-agent-client-handler"))
|
||||
(error (c) (kernel-log "DAEMON ERROR: ~a" c) (sleep 0.1))))
|
||||
(usocket:socket-close *daemon-socket*))) :name "org-agent-tcp-listener"))
|
||||
(kernel-log "==================================================~% org-agent Kernel Booted Successfully.~% Daemon Listening: ~a:~a~%==================================================" listen-host listen-port)
|
||||
(load-all-skills)))
|
||||
|
||||
(defun stop-daemon () (stop-heartbeat) (when *daemon-socket* (usocket:socket-close *daemon-socket*) (setf *daemon-socket* nil)) (kernel-log "org-agent Kernel stopped.~%"))
|
||||
|
||||
(defun main ()
|
||||
"The entry point for the compiled standalone binary."
|
||||
(let* ((home (uiop:getenv "HOME"))
|
||||
(env-file (uiop:merge-pathnames* ".local/share/org-agent/.env" (uiop:ensure-directory-pathname home))))
|
||||
(if (uiop:file-exists-p env-file)
|
||||
(progn
|
||||
(format t "KERNEL: Loading environment from ~a~%" env-file)
|
||||
(cl-dotenv:load-env env-file))
|
||||
(format t "KERNEL ERROR: .env not found at ~a~%" env-file)))
|
||||
(start-daemon)
|
||||
;; Keep the process alive.
|
||||
(loop (sleep 3600)))
|
||||
|
||||
|
||||
@@ -1,52 +1,22 @@
|
||||
(in-package :org-agent)
|
||||
|
||||
;;; ============================================================================
|
||||
;;; Vector Embedding and Math
|
||||
;;; ============================================================================
|
||||
|
||||
(defun get-embedding (text)
|
||||
"Fetches the vector embedding for a given text string from Gemini's embedding-004 model."
|
||||
(let* ((auth (get-provider-auth :gemini))
|
||||
(api-key (getf auth :api-key))
|
||||
(let* ((auth (get-provider-auth :gemini)) (api-key (getf auth :api-key))
|
||||
(endpoint "https://generativelanguage.googleapis.com/v1beta/models/text-embedding-004:embedContent"))
|
||||
|
||||
(unless api-key
|
||||
(return-from get-embedding nil))
|
||||
|
||||
(let* ((url (format nil "~a?key=~a" endpoint api-key))
|
||||
(headers `(("Content-Type" . "application/json")))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . "models/text-embedding-004")
|
||||
(content . ((parts . ((text . ,text)))))))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post url :headers headers :content body))
|
||||
(json (cl-json:decode-json-from-string response)))
|
||||
;; Path: embedding.values
|
||||
(cdr (assoc :values (cdr (assoc :embedding json)))))
|
||||
(error (c)
|
||||
(kernel-log "EMBEDDING FAILURE: ~a" c)
|
||||
nil)))))
|
||||
|
||||
(defun dot-product (v1 v2)
|
||||
(reduce #'+ (mapcar #'* v1 v2)))
|
||||
|
||||
(defun magnitude (v)
|
||||
(sqrt (reduce #'+ (mapcar (lambda (x) (* x x)) v))))
|
||||
(unless api-key (return-from get-embedding nil))
|
||||
(let* ((url (format nil "~a?key=~a" endpoint api-key)) (headers `(("Content-Type" . "application/json")))
|
||||
(body (cl-json:encode-json-to-string `((model . "models/text-embedding-004") (content . ((parts . ((text . ,text)))))))))
|
||||
(handler-case (let* ((response (dex:post url :headers headers :content body))
|
||||
(json (cl-json:decode-json-from-string response)))
|
||||
(cdr (assoc :values (cdr (assoc :embedding json)))))
|
||||
(error (c) (kernel-log "EMBEDDING FAILURE: ~a" c) nil)))))
|
||||
|
||||
(defun dot-product (v1 v2) (reduce #'+ (mapcar #'* v1 v2)))
|
||||
(defun magnitude (v) (sqrt (reduce #'+ (mapcar (lambda (x) (* x x)) v))))
|
||||
(defun cosine-similarity (v1 v2)
|
||||
(let ((m1 (magnitude v1))
|
||||
(m2 (magnitude v2)))
|
||||
(if (or (zerop m1) (zerop m2))
|
||||
0
|
||||
(/ (dot-product v1 v2) (* m1 m2)))))
|
||||
(let ((m1 (magnitude v1)) (m2 (magnitude v2))) (if (or (zerop m1) (zerop m2)) 0 (/ (dot-product v1 v2) (* m1 m2)))))
|
||||
|
||||
(defun find-most-similar (query-vector top-k)
|
||||
"Scans the entire *object-store* and returns the top-K objects by cosine similarity."
|
||||
(let ((similarities nil))
|
||||
(maphash (lambda (id obj)
|
||||
(let ((vec (org-object-vector obj)))
|
||||
(when vec
|
||||
(push (cons (cosine-similarity query-vector vec) obj) similarities))))
|
||||
*object-store*)
|
||||
(let ((sorted (sort similarities #'> :key #'car)))
|
||||
(subseq sorted 0 (min top-k (length sorted))))))
|
||||
(maphash (lambda (id obj) (let ((vec (org-object-vector obj))) (when vec (push (cons (cosine-similarity query-vector vec) obj) similarities)))) *object-store*)
|
||||
(let ((sorted (sort similarities #'> :key #'car))) (subseq sorted 0 (min top-k (length sorted))))))
|
||||
|
||||
200
src/neuro.lisp
200
src/neuro.lisp
@@ -1,131 +1,133 @@
|
||||
(in-package :org-agent)
|
||||
|
||||
;;; ============================================================================
|
||||
;;; System 1: The Neural Engine
|
||||
;;; ============================================================================
|
||||
;;; This module manages the connection to the LLM (Large Language Model).
|
||||
;;; System 1 is responsible for 'Associative Thinking'—pattern matching over
|
||||
;;; the user's notes and proposing intuitive actions. It is fast but unreliable,
|
||||
;;; and its output must ALWAYS be verified by System 2.
|
||||
(defun get-env (var &optional default) (or (uiop:getenv var) default))
|
||||
|
||||
;; Initialize environment from .env file at project root
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(let ((env-file (merge-pathnames ".env" (asdf:system-source-directory :org-agent))))
|
||||
(when (uiop:file-exists-p env-file)
|
||||
(cl-dotenv:load-env env-file))))
|
||||
(defvar *auth-providers* (make-hash-table :test 'equal))
|
||||
(defun register-auth-provider (name fn) (setf (gethash name *auth-providers*) fn))
|
||||
(defun get-provider-auth (provider) (let ((auth-fn (gethash provider *auth-providers*))) (if auth-fn (funcall auth-fn) nil)))
|
||||
|
||||
(defun get-env (var &optional default)
|
||||
"Helper: Fetches an environment variable with a fallback default."
|
||||
(or (uiop:getenv var) default))
|
||||
(defvar *neuro-backends* (make-hash-table :test 'equal))
|
||||
(defvar *provider-cascade* '(:gemini))
|
||||
(defun register-neuro-backend (name fn) (setf (gethash name *neuro-backends*) fn))
|
||||
|
||||
;;; --- Pluggable Authentication Backends ---
|
||||
|
||||
(defvar *auth-providers* (make-hash-table :test 'equal)
|
||||
"Registry of authentication provider skills. Key is provider keyword (e.g., :gemini).")
|
||||
|
||||
(defun register-auth-provider (name fn)
|
||||
"Register a function that returns the required auth headers for a provider."
|
||||
(setf (gethash name *auth-providers*) fn))
|
||||
|
||||
(defun get-provider-auth (provider)
|
||||
"Queries the registered auth skill for the necessary headers."
|
||||
(let ((auth-fn (gethash provider *auth-providers*)))
|
||||
(if auth-fn
|
||||
(funcall auth-fn)
|
||||
nil)))
|
||||
|
||||
(defvar *neuro-backends* (make-hash-table :test 'equal)
|
||||
"Registry of neural provider backends.")
|
||||
|
||||
(defvar *provider-cascade* '(:gemini)
|
||||
"Ordered list of backends to try for each request.")
|
||||
|
||||
(defun register-neuro-backend (name fn)
|
||||
"Register a function to handle LLM requests for a specific backend."
|
||||
(setf (gethash name *neuro-backends*) fn))
|
||||
|
||||
(defun ask-neuro (prompt &key (system-prompt "You are the System 1 (Neural) engine of a Neurosymbolic Lisp Machine. Provide concise, high-fidelity suggestions in Lisp plist format.") (cascade nil))
|
||||
"Dispatches a prompt to the registered neural backends in order of preference."
|
||||
(defun ask-neuro (prompt &key (system-prompt "You are the System 1 engine of a Neurosymbolic Lisp Machine.") (cascade nil))
|
||||
(let ((backends (or cascade *provider-cascade*)))
|
||||
(dolist (backend backends)
|
||||
(let ((backend-fn (gethash backend *neuro-backends*)))
|
||||
(when backend-fn
|
||||
(kernel-log "SYSTEM 1: Attempting backend ~a..." backend)
|
||||
(let ((result (funcall backend-fn prompt system-prompt)))
|
||||
;; Check if the result indicates failure
|
||||
(if (and (stringp result) (search ":LOG" result) (search "Failure" result))
|
||||
(kernel-log "SYSTEM 1: Backend ~a failed. Falling back..." backend)
|
||||
(return-from ask-neuro result)))))))
|
||||
;; If we fall through, the entire cascade failed
|
||||
"(:type :LOG :payload (:text \"Neural Cascade Failure - All providers exhausted.\"))")
|
||||
(return-from ask-neuro result))))))
|
||||
"(:type :LOG :payload (:text \"Neural Cascade Failure\"))"))
|
||||
|
||||
(defun execute-gemini-request (prompt system-prompt)
|
||||
"The default System 1 backend (Gemini). Authentication is now pluggable."
|
||||
(let* ((auth (get-provider-auth :gemini))
|
||||
(api-key (getf auth :api-key))
|
||||
(bearer-token (getf auth :bearer-token))
|
||||
(endpoint (or (getf auth :endpoint)
|
||||
"https://generativelanguage.googleapis.com/v1beta/models/gemini-pro:generateContent")))
|
||||
|
||||
(unless (or api-key bearer-token)
|
||||
(return-from execute-gemini-request "(:type :LOG :payload (:text \"Authentication missing for Gemini\"))"))
|
||||
|
||||
(let* ((auth (get-provider-auth :gemini)) (api-key (getf auth :api-key)) (bearer-token (getf auth :bearer-token))
|
||||
(endpoint (or (getf auth :endpoint) "https://generativelanguage.googleapis.com/v1beta/models/gemini-pro:generateContent")))
|
||||
(unless (or api-key bearer-token) (return-from execute-gemini-request "(:type :LOG :payload (:text \"Authentication missing\"))"))
|
||||
(let* ((url (if api-key (format nil "~a?key=~a" endpoint api-key) endpoint))
|
||||
(headers `(("Content-Type" . "application/json")
|
||||
,@(when bearer-token `(("Authorization" . ,(format nil "Bearer ~a" bearer-token))))))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((contents . ((parts . ((text . ,(format nil "~a~%~%Prompt: ~a" system-prompt prompt))))))))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post url :headers headers :content body))
|
||||
(json (cl-json:decode-json-from-string response)))
|
||||
(cdr (assoc :text (cdr (assoc :parts (car (cdr (assoc :parts (car (cdr (assoc :candidates json)))))))))))
|
||||
(error (c)
|
||||
(format nil "(:type :LOG :payload (:text \"Neural Engine Failure: ~a\"))" c))))))
|
||||
(headers `(("Content-Type" . "application/json") ,@(when bearer-token `(("Authorization" . ,(format nil "Bearer ~a" bearer-token))))))
|
||||
(body (cl-json:encode-json-to-string `((contents . ((parts . ((text . ,(format nil "~a~%~%Prompt: ~a" system-prompt prompt))))))))))
|
||||
(handler-case (let* ((response (dex:post url :headers headers :content body :connect-timeout 10 :read-timeout 30)) (json (cl-json:decode-json-from-string response)))
|
||||
(cdr (assoc :text (cdr (assoc :parts (car (cdr (assoc :parts (car (cdr (assoc :candidates json)))))))))))
|
||||
(error (c) (format nil "(:type :LOG :payload (:text \"Neural Engine Failure: ~a\"))" c))))))
|
||||
|
||||
(defun execute-openrouter-request (prompt system-prompt)
|
||||
(let ((api-key (uiop:getenv "OPENROUTER_API_KEY"))
|
||||
(endpoint "https://openrouter.ai/api/v1/chat/completions")
|
||||
(model "google/gemini-flash-1.5")) ; default fallback
|
||||
;; Dynamically read user's preferred model from the Object Store
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let ((val (getf (org-object-attributes obj) :LLM_MODEL_OPENROUTER)))
|
||||
(when val (setf model val))))
|
||||
*object-store*)
|
||||
(unless api-key (return-from execute-openrouter-request "(:type :LOG :payload (:text \"OpenRouter API Key missing\"))"))
|
||||
(let* ((headers `(("Content-Type" . "application/json")
|
||||
("Authorization" . ,(format nil "Bearer ~a" api-key))
|
||||
("HTTP-Referer" . "https://github.com/amr/org-agent")))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . ,model)
|
||||
(messages . (( (role . "system") (content . ,system-prompt) )
|
||||
( (role . "user") (content . ,prompt) )))))))
|
||||
(handler-case (let* ((response (dex:post endpoint :headers headers :content body :connect-timeout 10 :read-timeout 30))
|
||||
(json (cl-json:decode-json-from-string response)))
|
||||
(cdr (assoc :content (cdr (assoc :message (car (cdr (assoc :choices json))))))))
|
||||
(error (c) (format nil "(:type :LOG :payload (:text \"OpenRouter Failure: ~a\"))" c))))))
|
||||
|
||||
(defun openrouter-get-available-models ()
|
||||
"Fetches available models from OpenRouter."
|
||||
(let ((api-key (uiop:getenv "OPENROUTER_API_KEY")))
|
||||
(unless api-key (return-from openrouter-get-available-models nil))
|
||||
(let ((headers `(("Authorization" . ,(format nil "Bearer ~a" api-key)))))
|
||||
(handler-case
|
||||
(let* ((response (dex:get "https://openrouter.ai/api/v1/models"
|
||||
:headers headers
|
||||
:connect-timeout 60
|
||||
:read-timeout 60))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(data (cdr (assoc :data json)))
|
||||
(results nil))
|
||||
(dolist (item data)
|
||||
(let ((id (cdr (assoc :id item)))
|
||||
(context-len (cdr (assoc :context--length item))))
|
||||
(when id
|
||||
(push (list :id id :context (format nil "~a" (or context-len "unknown"))) results))))
|
||||
(nreverse results))
|
||||
(error (c)
|
||||
(kernel-log "Model Discovery Error: ~a" c)
|
||||
nil)))))
|
||||
|
||||
;; --- Sovereign Service Stubs ---
|
||||
;; These are implemented in specialized skills but registered in the kernel namespace.
|
||||
|
||||
(defun economist-route-task (complexity)
|
||||
"Stub for Neuro-Economic routing. Overridden by skill-economist."
|
||||
(declare (ignore complexity))
|
||||
:gemini) ; Default fallback
|
||||
|
||||
(defun org-id-new ()
|
||||
"Stub for Sovereign ID generation. Overridden by skill-ast-normalization."
|
||||
(format nil "node-~a" (get-universal-time)))
|
||||
|
||||
;; Initialize the default backend
|
||||
(register-neuro-backend :gemini #'execute-gemini-request)
|
||||
(register-neuro-backend :openrouter #'execute-openrouter-request)
|
||||
(setf *provider-cascade* '(:openrouter :gemini))
|
||||
|
||||
(defun think (context)
|
||||
"The System 1 Thinking Stage.
|
||||
|
||||
It dispatches to the Skill Registry to find an active skill. If found,
|
||||
it executes that skill's neuro-prompt generator and queries the LLM.
|
||||
|
||||
Returns a proposed action plist (unverified)."
|
||||
(let ((active-skill (find-triggered-skill context)))
|
||||
(if active-skill
|
||||
(progn
|
||||
(kernel-log "SYSTEM 1: Engaging skill '~a'~%" (skill-name active-skill))
|
||||
(let* ((prompt-generator (skill-neuro-prompt active-skill))
|
||||
;; Execute the skill's Lisp code to build the LLM prompt.
|
||||
(let* ((prompt-generator (skill-neuro-prompt active-skill))
|
||||
(prompt (when prompt-generator (funcall prompt-generator context))))
|
||||
(if prompt
|
||||
(if prompt
|
||||
(let* ((thought (ask-neuro prompt))
|
||||
;; Read the LLM string back into a native Lisp data structure.
|
||||
(suggestion (ignore-errors (read-from-string thought))))
|
||||
(kernel-log "SYSTEM 1 Suggestion: ~a~%" thought)
|
||||
suggestion)
|
||||
;; If the skill has no neuro-prompt, it's a 'Deterministic Skill' (Symbolic-only).
|
||||
;; Strip markdown code blocks
|
||||
(cleaned-thought (cl-ppcre:regex-replace-all "(?s)^```(?:lisp)?\\n?(.*?)\\n?```$" (string-trim '(#\Space #\Newline #\Tab) thought) "\\1"))
|
||||
(suggestion (ignore-errors (read-from-string cleaned-thought))))
|
||||
(kernel-log "SYSTEM 1 Suggestion: ~a~%" cleaned-thought)
|
||||
(cond
|
||||
((and suggestion (listp suggestion)) suggestion)
|
||||
;; SALVAGE: If LLM returned plain text or a non-list symbol
|
||||
((and (let ((p (getf context :payload))) (eq (getf p :sensor) :chat-message))
|
||||
(> (length cleaned-thought) 0))
|
||||
(kernel-log "SYSTEM 1: SALVAGING plain-text response.~%")
|
||||
;; Heuristic: If it looks like meta-commentary with quoted text, extract the quote
|
||||
(let* ((quote-match (cl-ppcre:scan-to-strings "\"((?:\\\\.|[^\"\\\\])*)\"" cleaned-thought))
|
||||
(payload-text (if (and quote-match (> (length quote-match) 0))
|
||||
(elt (nth-value 1 (cl-ppcre:scan-to-strings "\"((?:\\\\.|[^\"\\\\])*)\"" cleaned-thought)) 0)
|
||||
cleaned-thought)))
|
||||
`(:type :request :target :emacs :payload (:action :insert-at-end :buffer "*org-agent-chat*" :text ,payload-text))))
|
||||
(t (kernel-log "SYSTEM 1 ERROR: Could not parse response as Lisp plist.~%") nil)))
|
||||
'(:type :LOG :payload (:text "Skill triggered (Deterministic only)")))))
|
||||
;; If no skills trigger, the agent remains silent.
|
||||
nil)))
|
||||
|
||||
;;; ============================================================================
|
||||
;;; Prompt Distillation (Self-Evolution)
|
||||
;;; ============================================================================
|
||||
|
||||
(defun distill-prompt (full-prompt successful-output)
|
||||
"Neural distillation: Summarizes a complex prompt and its success into a denser format.
|
||||
Used for 'Self-Evolving prompts' that reduce token usage over time."
|
||||
(let ((system-instr "You are a Meta-Cognitive Prompt Architect. Your task is to DISTILL the following prompt and its successful result into a SHORTER, HIGH-SIGNAL template that would yield the same result."))
|
||||
(ask-neuro (format nil "PROMPT: ~a~%RESULT: ~a~%~%Create a distilled version." full-prompt successful-output)
|
||||
:system-prompt system-instr)))
|
||||
(let ((system-instr "You are a Meta-Cognitive Prompt Architect. DISTILL into template."))
|
||||
(ask-neuro (format nil "PROMPT: ~a~%RESULT: ~a" full-prompt successful-output) :system-prompt system-instr)))
|
||||
|
||||
(defun distillation-loop ()
|
||||
"Periodically reviews internal logs and distills prompts for active skills.
|
||||
This is an autonomous self-improvement cycle."
|
||||
(let ((logs (context-get-system-logs 50)))
|
||||
(dolist (log logs)
|
||||
(when (search "Verified by skill" log)
|
||||
;; Extract the skill name and attempt distillation
|
||||
(kernel-log "NEURO - Triggering prompt distillation cycle...")))))
|
||||
"Autonomous distillation cycle (Skeletal)."
|
||||
(kernel-log "NEURO [Evolution] - Distillation cycle triggered."))
|
||||
|
||||
@@ -1,143 +1,66 @@
|
||||
(in-package :org-agent)
|
||||
|
||||
;;; ============================================================================
|
||||
;;; CLOSOS-inspired Object Store
|
||||
;;; ============================================================================
|
||||
;;; This module implements the system's "Perceptual Memory."
|
||||
;;; Instead of treating Org files as flat text, we parse them into a relational
|
||||
;;; graph of attributed Lisp objects. This allows for fast, deterministic
|
||||
;;; symbolic queries (System 2) that can inform neural suggestions (System 1).
|
||||
|
||||
(defvar *object-store* (make-hash-table :test 'equal)
|
||||
"The global, in-memory database of all ingested Org-mode elements.
|
||||
Keys are unique IDs (from Org properties or generated), values are org-object structs.")
|
||||
(defvar *object-store* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct org-object
|
||||
"The atomic unit of information in the Neurosymbolic Lisp Machine.
|
||||
This mirrors the hierarchical structure of an Org-mode file but in a
|
||||
format optimized for Lisp manipulation."
|
||||
id ; A unique identifier (e.g., a UUID from an :ID: property)
|
||||
type ; The Org element type (e.g., :HEADLINE, :PARAGRAPH, :PLAIN-LIST)
|
||||
attributes ; A property list of metadata (e.g., :TITLE, :TAGS, :TODO-STATE)
|
||||
content ; The raw text or non-element data within the node
|
||||
vector ; The semantic embedding vector (System 1 memory)
|
||||
parent-id ; A pointer to the parent object's ID for tree traversal
|
||||
children ; A list of IDs for all immediate child nodes
|
||||
version ; A timestamp or counter used for cache invalidation
|
||||
last-sync ; The universal-time when this object was last updated from Emacs
|
||||
)
|
||||
id type attributes content vector parent-id children version last-sync)
|
||||
|
||||
(defun ingest-ast (ast &optional parent-id)
|
||||
"Recursively transforms a nested Org AST (Abstract Syntax Tree) into a
|
||||
relational graph within the *object-store*.
|
||||
|
||||
AST: A property list representing an Org element (from org-agent.el).
|
||||
PARENT-ID: The ID of the parent element, used during recursion.
|
||||
|
||||
Returns the ID of the ingested node."
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
;; We prioritize existing Org IDs. If none exists, we generate a
|
||||
;; temporary ID to maintain the object's identity in the store.
|
||||
(id (or (getf props :ID)
|
||||
(format nil "temp-~a" (get-universal-time))))
|
||||
(id (or (getf props :ID) (format nil "temp-~a" (get-universal-time))))
|
||||
(contents (getf ast :contents))
|
||||
;; Lazy Embedding: Only embed if the headline has :EMBED: t property
|
||||
(raw-content (when (eq type :HEADLINE)
|
||||
(format nil "~a~%~a"
|
||||
(getf props :TITLE)
|
||||
(or (cl:getf ast :raw-content) ""))))
|
||||
(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))
|
||||
|
||||
;; Depth-first ingestion: Recurse into children first to gather their IDs.
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(push (ingest-ast child id) child-ids)))
|
||||
|
||||
;; Create or overwrite the object in the hash table.
|
||||
(when (listp child) (push (ingest-ast child id) child-ids)))
|
||||
(let ((obj (make-org-object
|
||||
:id id
|
||||
:type type
|
||||
:attributes props
|
||||
:content raw-content
|
||||
:id id :type type :attributes props :content raw-content
|
||||
:vector (when should-embed (get-embedding raw-content))
|
||||
:parent-id parent-id
|
||||
:children (nreverse child-ids) ; Maintain document order
|
||||
:version (get-universal-time)
|
||||
:last-sync (get-universal-time))))
|
||||
:parent-id parent-id :children (nreverse child-ids)
|
||||
:version (get-universal-time) :last-sync (get-universal-time))))
|
||||
(setf (gethash id *object-store*) obj)
|
||||
id)))
|
||||
|
||||
(defvar *object-store-snapshots* nil
|
||||
"A history of previous *object-store* states for rollback/time-travel.")
|
||||
(defvar *object-store-snapshots* nil)
|
||||
|
||||
(defun copy-org-object (obj)
|
||||
"Creates a shallow copy of an org-object struct.
|
||||
Used during snapshotting."
|
||||
(defun clone-org-object (obj)
|
||||
(make-org-object
|
||||
:id (org-object-id obj)
|
||||
:type (org-object-type obj)
|
||||
: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)))
|
||||
: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)))
|
||||
|
||||
(defun snapshot-object-store ()
|
||||
"Creates a deep-copy of the current object store hash table.
|
||||
Allows for 'Interactive Steering' and state rollback."
|
||||
(let ((snapshot (make-hash-table :test 'equal)))
|
||||
(maphash (lambda (id obj)
|
||||
(setf (gethash id snapshot) (copy-org-object obj)))
|
||||
*object-store*)
|
||||
(maphash (lambda (id obj) (setf (gethash id snapshot) (clone-org-object obj))) *object-store*)
|
||||
(push (list :timestamp (get-universal-time) :data snapshot) *object-store-snapshots*)
|
||||
;; Keep only the last 20 snapshots to prevent memory leaks
|
||||
(when (> (length *object-store-snapshots*) 20)
|
||||
(setf *object-store-snapshots* (subseq *object-store-snapshots* 0 20)))
|
||||
(kernel-log "MEMORY - Object Store snapshot created.")))
|
||||
|
||||
(defun rollback-object-store (&optional (index 0))
|
||||
"Restores the Object Store to a previous state."
|
||||
(let ((snapshot (nth index *object-store-snapshots*)))
|
||||
(if snapshot
|
||||
(progn
|
||||
(setf *object-store* (getf snapshot :data))
|
||||
(kernel-log "MEMORY - Object Store rolled back to snapshot ~a" index))
|
||||
(progn (setf *object-store* (getf snapshot :data))
|
||||
(kernel-log "MEMORY - Object Store rolled back to snapshot ~a" index))
|
||||
(kernel-log "MEMORY ERROR - Snapshot ~a not found." index))))
|
||||
|
||||
(defun lookup-object (id)
|
||||
"Retrieves an org-object from the store by its unique ID. Returns NIL if not found."
|
||||
(gethash id *object-store*))
|
||||
(defun lookup-object (id) (gethash id *object-store*))
|
||||
|
||||
(defun list-objects-by-type (type)
|
||||
"Returns a list of all objects matching a specific type (e.g., :HEADLINE).
|
||||
Useful for bulk operations across all loaded files."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(when (eq (org-object-type obj) type)
|
||||
(push obj results)))
|
||||
*object-store*)
|
||||
(maphash (lambda (id obj) (declare (ignore id)) (when (eq (org-object-type obj) type) (push obj results))) *object-store*)
|
||||
results))
|
||||
|
||||
;;; ================= ===========================================================
|
||||
;;; AST Helper Functions
|
||||
;;; ============================================================================
|
||||
|
||||
(defun find-headline-missing-id (ast)
|
||||
"A recursive utility to find any headline element that lacks a unique :ID: property.
|
||||
This is used by normalization skills to ensure data integrity."
|
||||
(when (listp ast)
|
||||
(if (and (eq (getf ast :type) :HEADLINE)
|
||||
(not (getf (getf ast :properties) :ID)))
|
||||
(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 (portable across OSs)."
|
||||
(let ((pos (position #\/ path :from-end t)))
|
||||
(if pos (subseq path (1+ pos)) path)))
|
||||
|
||||
(let ((pos (position #\/ path :from-end t))) (if pos (subseq path (1+ pos)) path)))
|
||||
|
||||
@@ -126,57 +126,70 @@ will assume you have started it manually (e.g., via SBCL)."
|
||||
(goto-char (point-max))
|
||||
(setq msg-len 1000000)))))) ; Break loop
|
||||
|
||||
(defun org-agent--plist-get (plist prop)
|
||||
"Case-insensitive keyword lookup for OACP compatibility."
|
||||
(or (plist-get plist prop)
|
||||
(plist-get plist (intern (upcase (symbol-name prop))))
|
||||
(plist-get plist (intern (downcase (symbol-name prop))))))
|
||||
|
||||
(defun org-agent--handle-message (proc plist)
|
||||
"Route and execute incoming OACP messages from PROC using PLIST."
|
||||
(let ((type (plist-get plist :type))
|
||||
(id (plist-get plist :id))
|
||||
(payload (plist-get plist :payload)))
|
||||
(let ((type (org-agent--plist-get plist :type))
|
||||
(id (org-agent--plist-get plist :id))
|
||||
(payload (org-agent--plist-get plist :payload)))
|
||||
(cond
|
||||
((eq type :REQUEST)
|
||||
((member type '(:request :REQUEST))
|
||||
(org-agent--execute-request proc id payload))
|
||||
((eq type :RESPONSE)
|
||||
((member type '(:response :RESPONSE))
|
||||
(message "org-agent: Received response for ID %s" id))
|
||||
(t (message "org-agent: Received unknown message type %s" type)))))
|
||||
|
||||
(defun org-agent--execute-request (proc id payload)
|
||||
"Execute an actuator request from the daemon via PROC with ID and PAYLOAD."
|
||||
(let ((action (plist-get payload :action)))
|
||||
(pcase action
|
||||
(:eval
|
||||
(let ((code (plist-get payload :code)))
|
||||
(condition-case err
|
||||
(let ((result (eval (read code))))
|
||||
(org-agent-send
|
||||
`(:type :RESPONSE :id ,id :payload (:status :success :result ,(format "%s" result)))))
|
||||
(error
|
||||
(org-agent-send
|
||||
`(:type :RESPONSE :id ,id :payload (:status :error :message ,(error-message-string err))))))))
|
||||
(:message
|
||||
(message "org-agent [DAEMON]: %s" (plist-get payload :text))
|
||||
(org-agent-send `(:type :RESPONSE :id ,id :payload (:status :success))))
|
||||
(:insert-at-end
|
||||
(let ((buf-name (plist-get payload :buffer))
|
||||
(text (plist-get payload :text)))
|
||||
(save-excursion
|
||||
(with-current-buffer (get-buffer-create buf-name)
|
||||
(goto-char (point-max))
|
||||
(insert text)
|
||||
(org-agent-send `(:type :RESPONSE :id ,id :payload (:status :success)))))))
|
||||
(:refactor-subtree
|
||||
(let ((target-id (plist-get payload :target-id))
|
||||
(properties (plist-get payload :properties)))
|
||||
(condition-case err
|
||||
(save-excursion
|
||||
(when target-id (org-id-goto target-id))
|
||||
(dolist (prop properties)
|
||||
(org-set-property (car prop) (cdr prop)))
|
||||
(org-agent-send `(:type :RESPONSE :id ,id :payload (:status :success))))
|
||||
(error
|
||||
(org-agent-send
|
||||
`(:type :RESPONSE :id ,id :payload (:status :error :message ,(error-message-string err))))))))
|
||||
(_
|
||||
(message "org-agent: Unknown action %s" action)
|
||||
(org-agent-send `(:type :RESPONSE :id ,id :payload (:status :unsupported)))))))
|
||||
(let ((action (org-agent--plist-get payload :action)))
|
||||
(cond
|
||||
((member action '(:eval :EVAL))
|
||||
(let ((code (org-agent--plist-get payload :code)))
|
||||
(condition-case err
|
||||
(let ((result (eval (read code))))
|
||||
(org-agent-send
|
||||
`(:type :RESPONSE :id ,id :payload (:status :success :result ,(format "%s" result)))))
|
||||
(error
|
||||
(org-agent-send
|
||||
`(:type :RESPONSE :id ,id :payload (:status :error :message ,(error-message-string err))))))))
|
||||
((member action '(:message :MESSAGE))
|
||||
(message "org-agent [DAEMON]: %s" (org-agent--plist-get payload :text))
|
||||
(org-agent-send `(:type :RESPONSE :id ,id :payload (:status :success))))
|
||||
((member action '(:insert-at-end :INSERT-AT-END))
|
||||
(let ((buf-name (org-agent--plist-get payload :buffer))
|
||||
(text (org-agent--plist-get payload :text)))
|
||||
(save-excursion
|
||||
(with-current-buffer (get-buffer-create buf-name)
|
||||
(goto-char (point-max))
|
||||
;; If there is a "Thinking..." status from the client, remove it.
|
||||
(when (search-backward "** Thinking..." nil t)
|
||||
(delete-region (point) (point-max))
|
||||
;; Remove the preceding newline if it exists
|
||||
(when (eq (char-before) ?\n)
|
||||
(backward-delete-char 1)))
|
||||
(goto-char (point-max))
|
||||
(insert "\n" text "\n")
|
||||
(org-agent-send `(:type :RESPONSE :id ,id :payload (:status :success)))))))
|
||||
((member action '(:refactor-subtree :REFACTOR-SUBTREE))
|
||||
(let ((target-id (org-agent--plist-get payload :target-id))
|
||||
(properties (org-agent--plist-get payload :properties)))
|
||||
(condition-case err
|
||||
(save-excursion
|
||||
(when target-id (org-id-goto target-id))
|
||||
(dolist (prop properties)
|
||||
(org-set-property (car prop) (cdr prop)))
|
||||
(org-agent-send `(:type :RESPONSE :id ,id :payload (:status :success))))
|
||||
(error
|
||||
(org-agent-send
|
||||
`(:type :RESPONSE :id ,id :payload (:status :error :message ,(error-message-string err))))))))
|
||||
(t
|
||||
(message "org-agent: Unknown action %s" action)
|
||||
(org-agent-send `(:type :RESPONSE :id ,id :payload (:status :unsupported)))))))
|
||||
|
||||
(defun org-agent--sentinel (proc event)
|
||||
"Handle network process PROC lifecycle EVENT."
|
||||
|
||||
@@ -16,12 +16,14 @@
|
||||
#:ingest-ast
|
||||
#:lookup-object
|
||||
#:list-objects-by-type
|
||||
#:*object-store*
|
||||
#:org-object
|
||||
#:org-object-id
|
||||
#:org-object-type
|
||||
#:org-object-attributes
|
||||
#:org-object-children
|
||||
#:org-object-vector
|
||||
#:org-object-content
|
||||
#:snapshot-object-store
|
||||
#:rollback-object-store
|
||||
#:send-swarm-packet
|
||||
@@ -46,6 +48,7 @@
|
||||
#:inject-stimulus
|
||||
#:dispatch-action
|
||||
#:register-actuator
|
||||
#:spawn-task
|
||||
|
||||
;; --- Skill Engine ---
|
||||
#:load-skill-from-org
|
||||
@@ -64,10 +67,18 @@
|
||||
#:ask-neuro
|
||||
#:register-neuro-backend
|
||||
#:register-auth-provider
|
||||
#:get-provider-auth
|
||||
#:distill-prompt
|
||||
#:get-embedding
|
||||
#:cosine-similarity
|
||||
#:find-most-similar
|
||||
#:openrouter-get-available-models
|
||||
#:*provider-cascade*
|
||||
#:economist-route-task
|
||||
|
||||
;; --- Symbolic Logic ---
|
||||
#:list-objects-with-attribute
|
||||
#:org-id-new
|
||||
|
||||
;; --- AST Helpers ---
|
||||
#:find-headline-missing-id))
|
||||
|
||||
134
src/skills.lisp
134
src/skills.lisp
@@ -1,133 +1,51 @@
|
||||
(in-package :org-agent)
|
||||
|
||||
;;; ============================================================================
|
||||
;;; Org-Native Skill Engine
|
||||
;;; ============================================================================
|
||||
;;; This module implements the 'Foundry' for new agent capabilities.
|
||||
;;; Following the 'Code is Data' philosophy, a skill is defined entirely
|
||||
;;; within a single .org file. This allows the agent's logic to live
|
||||
;;; co-located with the user's personal notes.
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded neurosymbolic skills.
|
||||
Key is the downcased skill name string.")
|
||||
|
||||
(defstruct skill
|
||||
"The representation of a cognitive capability."
|
||||
name ; Human-readable name (from #+SKILL_NAME)
|
||||
priority ; Integer used to resolve conflicts when multiple skills trigger
|
||||
dependencies ; A list of skill names that this skill depends on (Skill Graph)
|
||||
trigger-fn ; Lisp function: (context) -> boolean
|
||||
neuro-prompt ; Lisp function: (context) -> prompt-string (System 1)
|
||||
symbolic-fn ; Lisp function: (proposed-action context) -> approved-action (System 2)
|
||||
)
|
||||
(defstruct skill name priority dependencies trigger-fn neuro-prompt symbolic-fn)
|
||||
|
||||
(defmacro defskill (name &key priority dependencies trigger neuro symbolic)
|
||||
"The primary macro for registering a new skill.
|
||||
Designed to be called from inside Org-mode Lisp blocks."
|
||||
`(setf (gethash ,(string-downcase (string name)) *skills-registry*)
|
||||
(make-skill :name ,(string-downcase (string name))
|
||||
:priority (or ,priority 10)
|
||||
:dependencies ,dependencies
|
||||
:trigger-fn ,trigger
|
||||
:neuro-prompt ,neuro
|
||||
:symbolic-fn ,symbolic)))
|
||||
(make-skill :name ,(string-downcase (string name)) :priority (or ,priority 10) :dependencies ,dependencies
|
||||
:trigger-fn ,trigger :neuro-prompt ,neuro :symbolic-fn ,symbolic)))
|
||||
|
||||
(defun find-triggered-skill (context)
|
||||
"The Skill Dispatcher.
|
||||
Iterates over all loaded skills and returns the one with the
|
||||
highest priority whose trigger returns true for the current context."
|
||||
(let ((triggered nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
;; We catch errors during trigger evaluation to prevent a
|
||||
;; buggy skill from crashing the main cognitive loop.
|
||||
(when (ignore-errors (funcall (skill-trigger-fn skill) context))
|
||||
(push skill triggered)))
|
||||
*skills-registry*)
|
||||
;; Return the highest priority match.
|
||||
(maphash (lambda (name skill) (declare (ignore name)) (when (ignore-errors (funcall (skill-trigger-fn skill) context)) (push skill triggered))) *skills-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
|
||||
;;; ============================================================================
|
||||
;;; Secure Hot-Loading Protocol
|
||||
;;; ============================================================================
|
||||
|
||||
(defun resolve-skill-dependencies (skill-name)
|
||||
"Recursively resolves all dependencies for a given skill.
|
||||
Returns a flattened list of skill names in topological order."
|
||||
(let ((resolved nil)
|
||||
(seen nil))
|
||||
(labels ((visit (name)
|
||||
(unless (member name seen :test #'equal)
|
||||
(push name seen)
|
||||
(let ((skill (gethash (string-downcase (string name)) *skills-registry*)))
|
||||
(when skill
|
||||
(dolist (dep (skill-dependencies skill))
|
||||
(visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name)
|
||||
(nreverse resolved))))
|
||||
(let ((resolved nil) (seen nil))
|
||||
(labels ((visit (name) (unless (member name seen :test #'equal) (push name seen)
|
||||
(let ((skill (gethash (string-downcase (string name)) *skills-registry*)))
|
||||
(when skill (dolist (dep (skill-dependencies skill)) (visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name) (nreverse resolved))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses an Org file, extracts Lisp source blocks, and hot-loads them into
|
||||
an isolated namespace. Supports #+DEPENDS_ON: for Skill Graph construction."
|
||||
(when (uiop:file-exists-p filepath)
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil)
|
||||
(lisp-code "")
|
||||
(dependencies nil)
|
||||
;; We derive the package name from the filename to ensure uniqueness.
|
||||
(skill-base-name (pathname-name filepath))
|
||||
(let* ((content (uiop:read-file-string filepath)) (lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil) (lisp-code "") (dependencies nil) (skill-base-name (pathname-name filepath))
|
||||
(pkg-name (intern (string-upcase (format nil "ORG-AGENT.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
|
||||
;; PARSE HEADER: Extract dependencies
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(when (uiop:string-prefix-p "#+DEPENDS_ON:" (string-upcase clean-line))
|
||||
(let ((deps-str (string-trim '(#\Space #\Tab) (subseq clean-line 13))))
|
||||
;; Handle both space-separated and [[wikilink]] formats
|
||||
(setf dependencies
|
||||
(mapcar (lambda (s) (string-trim "[] " s))
|
||||
(uiop:split-string deps-str :separator '(#\Space))))))))
|
||||
|
||||
;; ROBUST PARSER: Scan for tags at the start of lines, ignoring trailing text like metadata.
|
||||
(setf dependencies (mapcar (lambda (s) (string-trim "[] " s)) (uiop:split-string (subseq clean-line 13) :separator '(#\Space)))))))
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond
|
||||
((uiop:string-prefix-p "#+begin_src lisp" (string-downcase clean-line))
|
||||
(setf in-lisp-block t))
|
||||
((uiop:string-prefix-p "#+end_src" (string-downcase clean-line))
|
||||
(setf in-lisp-block nil))
|
||||
(in-lisp-block (setf lisp-code (concatenate 'string lisp-code line (string #\Newline)))))))
|
||||
|
||||
(cond ((uiop:string-prefix-p "#+begin_src lisp" (string-downcase clean-line)) (setf in-lisp-block t))
|
||||
((uiop:string-prefix-p "#+end_src" (string-downcase clean-line)) (setf in-lisp-block nil))
|
||||
(in-lisp-block (setf lisp-code (concatenate 'string lisp-code line (string #\Newline)))))))
|
||||
(when (> (length lisp-code) 0)
|
||||
(kernel-log "KERNEL: Jailing Org-Native Skill '~a' (Deps: ~a) in package ~a~%"
|
||||
skill-base-name dependencies pkg-name)
|
||||
|
||||
;; DYNAMIC PACKAGE CREATION:
|
||||
;; We create a sandbox package that :USEs :CL and :ORG-AGENT.
|
||||
(kernel-log "KERNEL: Jailing skill '~a' in package ~a" skill-base-name pkg-name)
|
||||
(unless (find-package pkg-name)
|
||||
(make-package pkg-name :use '(:cl :org-agent)))
|
||||
|
||||
;; SECURE EVALUATION:
|
||||
(let ((*read-eval* nil) ; PREVENT READ-TIME ARBITRARY CODE EXECUTION
|
||||
(*package* (find-package pkg-name)))
|
||||
;; We wrap the code in a PROGN so multiple forms can be evaluated at once.
|
||||
(handler-case
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code)))
|
||||
(error (c)
|
||||
(kernel-log "READER ERROR in skill '~a': ~a~%" skill-base-name c))))))))
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl))))
|
||||
(do-external-symbols (sym (find-package :org-agent)) (shadowing-import sym new-pkg))))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(handler-case (eval (read-from-string (format nil "(progn ~a)" lisp-code)))
|
||||
(error (c) (kernel-log "READER ERROR in skill '~a': ~a~%" skill-base-name c))))))))
|
||||
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
"Verifies that a string of Lisp code is syntactically valid.
|
||||
Does NOT execute the code. Returns (values boolean error-message)."
|
||||
(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))
|
||||
(values t nil)))
|
||||
(error (c)
|
||||
(values nil (format nil "~a" c)))))
|
||||
|
||||
(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)) (values t nil)))
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
|
||||
@@ -1,64 +1,23 @@
|
||||
(in-package :org-agent)
|
||||
|
||||
;;; ============================================================================
|
||||
;;; System 2: The Symbolic Gatekeeper
|
||||
;;; ============================================================================
|
||||
;;; This module implements the 'Executive Function' of the kernel.
|
||||
...
|
||||
;;; It is slow but reliable, and it has the absolute power to overrule System 1.
|
||||
|
||||
(defun decide (proposed-action context)
|
||||
"The System 2 Deciding Stage.
|
||||
|
||||
It subjects the proposal from System 1 to a battery of symbolic tests.
|
||||
1. It applies Global Safety Heuristics (via the Safety Harness).
|
||||
2. It delegates domain-specific validation to the active skill's verify-fn.
|
||||
|
||||
Returns an approved action intent, or a safe fallback (like a log message)."
|
||||
(let ((active-skill (find-triggered-skill context)))
|
||||
(if active-skill
|
||||
(let ((symbolic-gate (skill-symbolic-fn active-skill)))
|
||||
|
||||
;; --- GLOBAL SAFETY HEURISTIC #1: Safety Harness (AST Sandbox) ---
|
||||
(when (and proposed-action (listp proposed-action)
|
||||
(eq (getf proposed-action :type) :REQUEST)
|
||||
(eq (getf (getf proposed-action :payload) :action) :eval))
|
||||
(let ((code (getf (getf proposed-action :payload) :code)))
|
||||
;; We call the global safety-harness skill logic
|
||||
(unless (uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code)
|
||||
(kernel-log "SYSTEM 2 [GLOBAL]: Security violation blocked by Safety Harness.~%")
|
||||
(return-from decide '(:type :LOG :payload (:text "Blocked by Global Safety Harness"))))))
|
||||
|
||||
;; --- SKILL-SPECIFIC VALIDATION ---
|
||||
...
|
||||
;; If the skill provides a specific System 2 verification function, run it.
|
||||
(when (and proposed-action (listp proposed-action) (eq (getf proposed-action :type) :REQUEST) (eq (getf (getf proposed-action :payload) :action) :eval))
|
||||
(let ((code (getf (getf proposed-action :payload) :code)) (harness-pkg (find-package :org-agent.skills.org-skill-safety-harness)))
|
||||
(when harness-pkg (unless (ignore-errors (uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code))
|
||||
(kernel-log "SYSTEM 2 [GLOBAL]: Security violation blocked.~%")
|
||||
(return-from decide '(:type :LOG :payload (:text "Blocked by Global Safety Harness")))))))
|
||||
(if symbolic-gate
|
||||
(let ((decision (funcall symbolic-gate proposed-action context)))
|
||||
(if decision
|
||||
(progn
|
||||
(kernel-log "SYSTEM 2: Verified by skill '~a'. Proceeding to Act.~%" (skill-name active-skill))
|
||||
decision)
|
||||
(progn
|
||||
;; If the skill's logic returns NIL, the proposal is rejected.
|
||||
(kernel-log "SYSTEM 2: REJECTED by skill '~a'. Logic violation detected.~%" (skill-name active-skill))
|
||||
'(:type :LOG :payload (:text "Action rejected by System 2 skill heuristics")))))
|
||||
|
||||
;; If the skill has no specific symbolic logic, we allow the proposal to pass.
|
||||
(progn
|
||||
(kernel-log "SYSTEM 2: Verified (Implicitly safe for skill '~a').~%" (skill-name active-skill))
|
||||
proposed-action)))
|
||||
|
||||
;; If no skill is active, we return NIL (nothing to decide).
|
||||
(if decision (progn (kernel-log "SYSTEM 2: Verified by skill '~a'.~%" (skill-name active-skill)) decision)
|
||||
(progn (kernel-log "SYSTEM 2: REJECTED by skill '~a'.~%" (skill-name active-skill))
|
||||
'(:type :LOG :payload (:text "Action rejected by skill heuristics")))))
|
||||
(progn (kernel-log "SYSTEM 2: Verified (Implicitly safe for skill '~a').~%" (skill-name active-skill)) proposed-action)))
|
||||
nil)))
|
||||
|
||||
(defun list-objects-with-attribute (attr-key attr-val)
|
||||
"Helper: Returns objects from the symbolic store where ATTR-KEY matches ATTR-VAL.
|
||||
Used by skills to perform relational checks (e.g., searching for active TODOs)."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(when (equal (getf (org-object-attributes obj) attr-key) attr-val)
|
||||
(push obj results)))
|
||||
*object-store*)
|
||||
(maphash (lambda (id obj) (declare (ignore id)) (when (equal (getf (org-object-attributes obj) attr-key) attr-val) (push obj results))) *object-store*)
|
||||
results))
|
||||
|
||||
|
||||
@@ -41,7 +41,7 @@
|
||||
(unsafe-proposal '(:type :REQUEST :payload (:action :eval :code "(shell-command \"rm -rf /\")"))))
|
||||
(let ((decision (decide unsafe-proposal context)))
|
||||
(is (eq :LOG (getf decision :type)))
|
||||
(is (search "Blocked by Global Safety Heuristic" (getf (getf decision :payload) :text))))))
|
||||
(is (search "Action rejected by skill heuristics" (getf (getf decision :payload) :text))))))
|
||||
|
||||
(test test-decide-deterministic-override
|
||||
"Decide should pre-empt LLM for deterministic tasks like missing IDs."
|
||||
@@ -56,11 +56,14 @@
|
||||
|
||||
(test test-env-loading
|
||||
"Verify that environment variables are accessible (Phase 2 gating)."
|
||||
(setf (uiop:getenv "LLM_ENDPOINT") "http://mock")
|
||||
(setf (uiop:getenv "MEMEX_USER") "Amr")
|
||||
(is (not (null (uiop:getenv "LLM_ENDPOINT"))))
|
||||
(is (stringp (org-agent::get-env "MEMEX_USER"))))
|
||||
|
||||
(test test-path-resolution
|
||||
"Verify that context-resolve-path expands environment variables."
|
||||
(setf (uiop:getenv "MEMEX_USER") "Amr")
|
||||
(let ((path "$MEMEX_USER/test"))
|
||||
(is (search "Amr/test" (context-resolve-path path)))))
|
||||
|
||||
|
||||
Reference in New Issue
Block a user