Compare commits
194 Commits
v0.1.0
...
feat/dispa
| Author | SHA1 | Date | |
|---|---|---|---|
| ec882f87fb | |||
| 5a0d1b1c38 | |||
| 299f72c2bb | |||
| dd478d8a7b | |||
| e2fde5914e | |||
| 0760dc8012 | |||
| 227ad81b30 | |||
| b6923d5584 | |||
| d35aea391e | |||
| 95d1ea3fed | |||
| d803889c01 | |||
| 5a3538ece1 | |||
| f1e375f237 | |||
| f80c16eed9 | |||
| 0d6854e610 | |||
| 2c5a271262 | |||
| 41de20d3f1 | |||
| 9e77958028 | |||
| 9191aecab2 | |||
| 48520ec517 | |||
| 6aec587e90 | |||
| a3d07209b6 | |||
| b63f5477c1 | |||
| 1eb8a3db92 | |||
| dabf52f234 | |||
| 21c792b019 | |||
| dd8bb6e3c8 | |||
| ddc60b8ff7 | |||
| 1080f0b873 | |||
| 6a6f4479ac | |||
| c0d3f066e8 | |||
| 31d3a52aeb | |||
| c180e55cb3 | |||
| 55599d3cba | |||
| 9faa861014 | |||
| 75957dfc69 | |||
| 5068e4a2c5 | |||
| 2030538281 | |||
| 45d8531efa | |||
| a616c509ca | |||
| 553c93e2c7 | |||
| 8a54e769c4 | |||
| 829bd7b7aa | |||
| 8ad7443d3f | |||
| ad891a86e6 | |||
| 224ede8cca | |||
| 9506b23ea6 | |||
| 9f71f7c391 | |||
| fa44b2a58e | |||
| 171652a887 | |||
| d6fa4a12d7 | |||
| 4ff9d519be | |||
| 63cf7bc033 | |||
| 27dd58f238 | |||
| f465dcc59c | |||
| 4669fcf22a | |||
| c2ffcd2c13 | |||
| def2774c8f | |||
| 14ef0d2cb8 | |||
| d3f2825558 | |||
| 1a1339c8fd | |||
| b8b9b2c9f9 | |||
| d078069a1a | |||
| 1ff614214a | |||
| 517fc20f4b | |||
| 770bbe2c56 | |||
| 585e19caca | |||
| f5098d5dc4 | |||
| 179e1a142c | |||
| 503d4536bf | |||
| 96fe9cdd94 | |||
| f56c3e1c61 | |||
| f3858b0330 | |||
| 014cd152db | |||
| 91c9bba50a | |||
| c8c146f6fa | |||
| 0491adede3 | |||
| de923311c3 | |||
| 189e76327e | |||
| 4d6ecc18c2 | |||
| 6b3bc195f3 | |||
| 03815fc154 | |||
| c9c687a832 | |||
| 41d66bcf52 | |||
| 357efbdb59 | |||
| a2d6c5ae38 | |||
| 285270146e | |||
| 356dd6711f | |||
| d15ff4b000 | |||
| f9a65cf3e7 | |||
| 2fd0047a08 | |||
| 06d3872d6a | |||
| e9cc1dc0eb | |||
| bf5e404fd9 | |||
| fd268edd91 | |||
| b46f19b4c9 | |||
| d15225a453 | |||
| 75cc9e3629 | |||
| d42b5fc50c | |||
| 6f1e606cfa | |||
| d55384fb65 | |||
| d787981d0d | |||
| b7f6eb68e9 | |||
| fd5513057e | |||
| d6a7e83de4 | |||
| 635db05d17 | |||
| 00c3f8ef69 | |||
| 8ed9a78d54 | |||
| a5538bf9d8 | |||
| 5be90dcb8f | |||
| ae7d0a4ee8 | |||
| aee1c9fa36 | |||
| e8a3980fb4 | |||
| 1fb284b8b0 | |||
| ee6b263584 | |||
| d73f372e4b | |||
| 545068e3c8 | |||
| 6d3cfc7bdc | |||
| 10206860db | |||
| 5323f759d0 | |||
| 609669b304 | |||
| 589ff1cb8d | |||
| ea0855f40b | |||
| 54b59c9019 | |||
| e31222d6e3 | |||
| fc0c069d65 | |||
| be870e0538 | |||
| 958ed69b4e | |||
| 45d74c2f3b | |||
| 38d8ec40e1 | |||
| 08109414e8 | |||
| e16d51e0f8 | |||
| 9707027a44 | |||
| 80e327dd20 | |||
| 3dddfe3e3d | |||
| a717ab1d3a | |||
| 41e25d091e | |||
| 215fe0eae7 | |||
| 43986fda9c | |||
| 2e8e79a193 | |||
| 75b7d5e710 | |||
| 87a0459497 | |||
| f1be82a00b | |||
| c8d8f1412d | |||
| 68105ffb46 | |||
| 861fb409fb | |||
| 6abc306c7f | |||
| edb8bed2d9 | |||
| 4e647a3631 | |||
| f940861921 | |||
| 8be187a968 | |||
| d0a9c2aa52 | |||
| 5d4979f5ab | |||
| 8063a63bfd | |||
| 664ba8243d | |||
| 43dbe3cf2d | |||
| 1e202629ce | |||
| fe4b80ba68 | |||
| aa1bf207b9 | |||
| eabba11a33 | |||
| 871c19c63a | |||
| 16de6924a2 | |||
| 854ad390e9 | |||
| 86eeaab66e | |||
| bcfffe15ee | |||
| f7209a8bb0 | |||
| 50558bf42a | |||
| 98900eabf1 | |||
| 44797e3d90 | |||
| ba057a57bf | |||
| 97168ae512 | |||
| 2cac7a730e | |||
| 31acf347de | |||
| d177a12469 | |||
| 249d537ca2 | |||
| 400eb07169 | |||
| 0d76e8d3d6 | |||
| 6d57abad11 | |||
| ac14cb0708 | |||
| 442f177177 | |||
| dfe318425f | |||
| 4e553f654e | |||
| 30c79834f5 | |||
| d4913261e2 | |||
| 05e166e454 | |||
| 037584b105 | |||
| de9da130a1 | |||
| ac9d1ac2fe | |||
| e685b43b8b | |||
| 40d90cca7a | |||
| 3f46b20192 | |||
| bd19f2f853 | |||
| 92b6f3cf2b | |||
| 9f6e189ea0 |
20
.env.example
20
.env.example
@@ -1,4 +1,4 @@
|
||||
# opencortex: Environment Configuration Template
|
||||
# passepartout: Environment Configuration Template
|
||||
# Copy this to .env and fill in your values
|
||||
|
||||
# =============================================================================
|
||||
@@ -15,6 +15,8 @@ OPENAI_API_KEY="your_openai_key_here"
|
||||
ANTHROPIC_API_KEY="your_anthropic_key_here"
|
||||
GROQ_API_KEY="your_groq_api_key_here"
|
||||
GEMINI_API_KEY="your_gemini_key_here"
|
||||
DEEPSEEK_API_KEY="your_deepseek_key_here"
|
||||
NVIDIA_API_KEY="your_nvidia_nim_key_here"
|
||||
|
||||
# Cascade order (first available provider wins)
|
||||
PROVIDER_CASCADE="openrouter,openai,anthropic,groq,gemini-api,ollama"
|
||||
@@ -25,7 +27,13 @@ PROVIDER_CASCADE="openrouter,openai,anthropic,groq,gemini-api,ollama"
|
||||
OLLAMA_HOST="localhost:11434"
|
||||
|
||||
# llama.cpp backend (for local GGUF models)
|
||||
LLAMACPP_ENDPOINT="http://localhost:8080"
|
||||
LLAMA_HOST="localhost:8080"
|
||||
|
||||
# =============================================================================
|
||||
# VECTOR EMBEDDINGS (semantic search)
|
||||
# =============================================================================
|
||||
EMBEDDING_PROVIDER="ollama" # "ollama" or "llama.cpp"
|
||||
EMBEDDING_MODEL="nomic-embed-text" # model name for embeddings
|
||||
|
||||
# =============================================================================
|
||||
# MESSAGING GATEWAYS (optional)
|
||||
@@ -50,10 +58,15 @@ SAFETY_BLOCK_SHELL=true
|
||||
PROTOCOL_ENFORCE_HMAC=false
|
||||
PROTOCOL_HMAC_SECRET="change-this-to-a-secure-random-string"
|
||||
|
||||
# Privacy filter tags: comma-separated list of tags that mark content as private.
|
||||
# Files/headings tagged with any of these will be filtered from LLM context.
|
||||
# Default: @personal
|
||||
PRIVACY_FILTER_TAGS="@personal,@health,@finance"
|
||||
|
||||
# =============================================================================
|
||||
# BOOTSTRAP
|
||||
# =============================================================================
|
||||
MANDATORY_SKILLS="org-skill-policy,org-skill-bouncer"
|
||||
MANDATORY_SKILLS="security-policy,security-dispatcher"
|
||||
|
||||
# =============================================================================
|
||||
# CONTEXT / MEMORY
|
||||
@@ -65,7 +78,6 @@ CONTEXT_LOG_LIMIT=20
|
||||
# MEMEX STRUCTURE
|
||||
# =============================================================================
|
||||
MEMEX_DIR="$HOME/memex"
|
||||
SKILLS_DIR="skills/"
|
||||
ZETTELKASTEN_DIR="$HOME/memex/notes"
|
||||
INBOX_DIR="$HOME/memex/inbox"
|
||||
DAILY_DIR="$HOME/memex/daily"
|
||||
|
||||
@@ -1,44 +1,24 @@
|
||||
name: Deploy-Agent-V15-Stdin
|
||||
name: Deploy (Gitea)
|
||||
|
||||
on:
|
||||
push:
|
||||
branches:
|
||||
- main
|
||||
|
||||
jobs:
|
||||
JOB-V15-STDIN:
|
||||
deploy:
|
||||
runs-on: debian-latest
|
||||
steps:
|
||||
- name: Checkout Code
|
||||
uses: actions/checkout@v3
|
||||
- name: Checkout
|
||||
uses: actions/checkout@v4
|
||||
|
||||
- name: Install Docker CLI
|
||||
run: |
|
||||
echo "Installing Docker CLI..."
|
||||
apt-get update
|
||||
apt-get install -y docker.io docker-compose
|
||||
apt-get update && apt-get install -y docker.io docker-compose
|
||||
|
||||
- name: Deploy via Host Docker Socket (Stdin Method)
|
||||
- name: Build and deploy via Docker Compose
|
||||
run: |
|
||||
echo "Piping local compose file to host Docker daemon..."
|
||||
|
||||
# We read the compose file from the checked-out code in the runner,
|
||||
# but we tell the host Docker daemon that the "project directory" is /memex/projects/opencortex.
|
||||
# The host daemon will use its own /memex files to build the image.
|
||||
|
||||
cat deploy/docker/docker-compose.yml | docker-compose \
|
||||
-p opencortex \
|
||||
--project-directory /memex/projects/opencortex \
|
||||
-f - \
|
||||
down
|
||||
|
||||
cat deploy/docker/docker-compose.yml | docker-compose \
|
||||
-p opencortex \
|
||||
--project-directory /memex/projects/opencortex \
|
||||
-f - \
|
||||
build --no-cache opencortex
|
||||
|
||||
cat deploy/docker/docker-compose.yml | docker-compose \
|
||||
-p opencortex \
|
||||
--project-directory /memex/projects/opencortex \
|
||||
-f - \
|
||||
up -d --force-recreate opencortex
|
||||
cd infrastructure/docker
|
||||
docker-compose -p passepartout down
|
||||
docker-compose -p passepartout build --no-cache passepartout
|
||||
docker-compose -p passepartout up -d --force-recreate passepartout
|
||||
|
||||
78
.github/workflows/lint.yml
vendored
78
.github/workflows/lint.yml
vendored
@@ -2,44 +2,86 @@ name: Lint
|
||||
|
||||
on:
|
||||
push:
|
||||
branches: [main]
|
||||
pull_request:
|
||||
branches: [main]
|
||||
tags:
|
||||
- 'v*'
|
||||
workflow_dispatch:
|
||||
|
||||
jobs:
|
||||
lint:
|
||||
runs-on: ubuntu-latest
|
||||
container:
|
||||
image: ubuntu:latest
|
||||
env:
|
||||
FORCE_JAVASCRIPT_ACTIONS_TO_NODE24: true
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
|
||||
- name: Install dependencies
|
||||
run: |
|
||||
apt-get update && apt-get install -y --no-install-recommends \
|
||||
sudo apt-get update && sudo apt-get install -y --no-install-recommends \
|
||||
git emacs-nox
|
||||
|
||||
- name: Check for forbidden patterns
|
||||
run: |
|
||||
grep -r "json\." --include="*.lisp" . && \
|
||||
echo "ERROR: Found JSON usage in Lisp files" && exit 1 || \
|
||||
! grep -r "json\." --include="*.lisp" . && \
|
||||
echo "OK: No JSON in Lisp files"
|
||||
|
||||
- name: Check literate granularity
|
||||
- name: Check skills have lisp source blocks
|
||||
run: |
|
||||
find . -name "*.org" -path "./skills/*" -exec grep -L "#+begin_src lisp" {} \; | \
|
||||
grep -v "CLA\|CONTRIBUTING\|CHANGELOG" && \
|
||||
echo "WARNING: Some skills lack lisp blocks" || \
|
||||
echo "OK: All skills have lisp blocks"
|
||||
FAIL=0
|
||||
for f in skills/*.org; do
|
||||
if ! grep -q "#+begin_src lisp" "$f"; then
|
||||
echo "WARNING: $f has no lisp blocks"
|
||||
FAIL=1
|
||||
fi
|
||||
done
|
||||
find . -name "*.org" -path "*/skills/*" -exec grep -L "#+begin_src lisp" {} \; | \
|
||||
grep -v "CLA\|CONTRIBUTING\|CHANGELOG\|README\|USER_MANUAL" || true
|
||||
echo "OK: All skills have lisp blocks"
|
||||
|
||||
- name: Verify .lisp files are generated
|
||||
- name: Verify each .lisp has a corresponding .org source
|
||||
run: |
|
||||
for f in library/gen/*.lisp; do
|
||||
FAIL=0
|
||||
for f in harness/*.lisp tests/*.lisp; do
|
||||
[ -f "$f" ] || continue
|
||||
org="${f%.lisp}.org"
|
||||
if [ -f "$org" ]; then
|
||||
: # generated, OK
|
||||
[ -f "$org" ] && continue
|
||||
base=$(basename "$f" .lisp)
|
||||
# Check if generated from a parent org via :tangle
|
||||
parent="${base%-tests}.org"
|
||||
parent="${parent%-validator}.org"
|
||||
parent="${parent%-client}.org"
|
||||
if [ -f "harness/$parent" ] || [ -f "skills/$parent" ]; then
|
||||
: # generated from parent org via :tangle
|
||||
elif grep -q ":tangle.*$(basename "$f")" harness/*.org skills/*.org 2>/dev/null; then
|
||||
: # :tangle reference found in another org
|
||||
else
|
||||
echo "WARNING: $f has no corresponding .org source"
|
||||
FAIL=1
|
||||
fi
|
||||
done
|
||||
done
|
||||
for f in skills/*.lisp; do
|
||||
[ -f "$f" ] || continue
|
||||
org="${f%.lisp}.org"
|
||||
if [ ! -f "$org" ]; then
|
||||
echo "ERROR: $f has no .org source"
|
||||
FAIL=1
|
||||
fi
|
||||
done
|
||||
[ "$FAIL" = 0 ] && echo "OK: All .lisp files have .org sources"
|
||||
|
||||
- name: Check literate granularity (one function per block)
|
||||
run: |
|
||||
for f in skills/*.org; do
|
||||
blocks=$(grep -c "^[[:space:]]*(defun " "$f" 2>/dev/null || true)
|
||||
srcblocks=$(grep -c "#+begin_src lisp" "$f" 2>/dev/null || true)
|
||||
if [ "$blocks" -gt "$srcblocks" ] && [ "$srcblocks" -gt 0 ]; then
|
||||
echo "WARNING: $f has $blocks defuns but only $srcblocks src blocks"
|
||||
fi
|
||||
done
|
||||
echo "OK: Granularity check complete"
|
||||
|
||||
- name: Check README has quick install
|
||||
run: |
|
||||
grep -q "curl.*passepartout" README.org && \
|
||||
echo "OK: Quick install in README" || \
|
||||
echo "WARNING: Quick install curl command not found in README"
|
||||
|
||||
8
.github/workflows/release.yml
vendored
8
.github/workflows/release.yml
vendored
@@ -16,16 +16,16 @@ jobs:
|
||||
|
||||
- name: Create tarball
|
||||
run: |
|
||||
git archive --format=tar.gz --prefix=opencortex-$(git describe --tags) HEAD -o opencortex.tar.gz
|
||||
git archive --format=tar.gz --prefix=passepartout-$(git describe --tags) HEAD -o passepartout.tar.gz
|
||||
|
||||
- name: Create zipball
|
||||
run: |
|
||||
git archive --format=zip --prefix=opencortex-$(git describe --tags) HEAD -o opencortex.zip
|
||||
git archive --format=zip --prefix=passepartout-$(git describe --tags) HEAD -o passepartout.zip
|
||||
|
||||
- name: Upload to GitHub Release
|
||||
uses: softprops/action-gh-release@v2
|
||||
with:
|
||||
files: |
|
||||
opencortex.tar.gz
|
||||
opencortex.zip
|
||||
passepartout.tar.gz
|
||||
passepartout.zip
|
||||
generate_release_notes: true
|
||||
100
.github/workflows/test.yml
vendored
100
.github/workflows/test.yml
vendored
@@ -2,43 +2,99 @@ name: Tests
|
||||
|
||||
on:
|
||||
push:
|
||||
branches: [main]
|
||||
pull_request:
|
||||
branches: [main]
|
||||
tags:
|
||||
- 'v*'
|
||||
workflow_dispatch:
|
||||
|
||||
jobs:
|
||||
test:
|
||||
runs-on: ubuntu-latest
|
||||
container:
|
||||
image: statusoftech/sbcl:2.4.0
|
||||
env:
|
||||
FORCE_JAVASCRIPT_ACTIONS_TO_NODE24: true
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v4
|
||||
|
||||
- name: Install dependencies
|
||||
- name: Install system dependencies
|
||||
run: |
|
||||
apt-get update && apt-get install -y --no-install-recommends \
|
||||
git curl openssl make automake autoconf gcc clisp python3 python3-pip
|
||||
sudo apt-get update && sudo apt-get install -y --no-install-recommends \
|
||||
sbcl emacs-nox git curl socat rlwrap
|
||||
|
||||
- name: Install Quicklisp
|
||||
run: |
|
||||
curl -L https://beta.quicklisp.org/quicklisp.lisp -o /tmp/quicklisp.lisp
|
||||
sbcl --non-interactive \
|
||||
curl -fsSL https://beta.quicklisp.org/quicklisp.lisp -o /tmp/quicklisp.lisp
|
||||
sbcl --noinform --non-interactive \
|
||||
--load /tmp/quicklisp.lisp \
|
||||
--eval '(quicklisp-quickstart:install :path "~/quicklisp/")' \
|
||||
--eval '(ql:add-to-init-file)'
|
||||
--eval '(quicklisp-quickstart:install)'
|
||||
rm -f /tmp/quicklisp.lisp
|
||||
|
||||
- name: Install ASDF systems
|
||||
- name: Load and verify harness
|
||||
run: |
|
||||
sbcl --non-interactive \
|
||||
--eval '(ql:quickload :opencortex)'
|
||||
env:
|
||||
HOME: /root
|
||||
export OC_DATA_DIR="$PWD/.github-test"
|
||||
mkdir -p "$OC_DATA_DIR/harness" "$OC_DATA_DIR/tests"
|
||||
|
||||
- name: Run tests
|
||||
# Tangle harness files into test directory
|
||||
mkdir -p /tmp/oc-build
|
||||
cp harness/*.org "$OC_DATA_DIR/harness/"
|
||||
cd "$OC_DATA_DIR/harness" && for f in *.org; do
|
||||
if command -v emacs; then
|
||||
emacs -Q --batch --eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"$f\")" 2>/dev/null || true
|
||||
fi
|
||||
done
|
||||
rm -f *.org
|
||||
cd "$OLDPWD"
|
||||
|
||||
# Copy skills, tangle, verify
|
||||
mkdir -p "$OC_DATA_DIR/skills"
|
||||
cp skills/*.org "$OC_DATA_DIR/skills/"
|
||||
cd "$OC_DATA_DIR/skills" && for f in *.org; do
|
||||
if command -v emacs; then
|
||||
emacs -Q --batch --eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
--eval "(org-babel-tangle-file \"$f\")" 2>/dev/null || true
|
||||
fi
|
||||
done
|
||||
rm -f *.org
|
||||
cd "$OLDPWD"
|
||||
|
||||
- name: Load passepartout and initialize skills
|
||||
run: |
|
||||
export OC_DATA_DIR="$PWD/.github-test"
|
||||
sbcl --non-interactive \
|
||||
--eval '(ql:quickload :opencortex/tests)' \
|
||||
--eval '(uiop:quit 0)'
|
||||
env:
|
||||
HOME: /root
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$PWD/\") asdf:*central-registry*)" \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout :silent t)' \
|
||||
--eval "(setf (uiop:getenv \"OC_DATA_DIR\") \"$OC_DATA_DIR\")" \
|
||||
--eval '(passepartout:initialize-all-skills)' \
|
||||
--eval "(let ((n (hash-table-count passepartout:*skills-registry*))) (format t \"~%Skills loaded: ~a~%\" n) (unless (>= n 20) (sb-ext:exit :code 1)))"
|
||||
|
||||
- name: Daemon smoke test
|
||||
run: |
|
||||
export OC_DATA_DIR="$PWD/.github-test"
|
||||
sbcl --non-interactive \
|
||||
--eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' \
|
||||
--eval "(push (truename \"$PWD/\") asdf:*central-registry*)" \
|
||||
--eval "(push (truename \"$OC_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval "(ql:quickload '(:passepartout :croatoan))" \
|
||||
--eval "(setf (uiop:getenv \"OC_DATA_DIR\") \"$OC_DATA_DIR\")" \
|
||||
--eval '(passepartout:main)' \
|
||||
> /tmp/oc-daemon.log 2>&1 &
|
||||
DAEMON_PID=$!
|
||||
|
||||
for i in $(seq 1 20); do
|
||||
if ss -tln 2>/dev/null | grep -q 9105; then
|
||||
echo "✓ Daemon ready on port 9105"
|
||||
# Read the initial handshake via a short TCP connection
|
||||
timeout 3 bash -c 'exec 3<>/dev/tcp/localhost/9105; head -c 200 <&3' 2>/dev/null | grep -q "handshake" && \
|
||||
echo "✓ Protocol handshake received"
|
||||
break
|
||||
fi
|
||||
sleep 1
|
||||
done
|
||||
|
||||
kill $DAEMON_PID 2>/dev/null || true
|
||||
wait $DAEMON_PID 2>/dev/null || true
|
||||
echo "✓ Daemon smoke test passed"
|
||||
|
||||
8
.gitignore
vendored
8
.gitignore
vendored
@@ -1,8 +1,12 @@
|
||||
.env
|
||||
opencortex-server
|
||||
passepartout-server
|
||||
\$MEMEX_DIR/
|
||||
*.log
|
||||
*~
|
||||
\#*#
|
||||
opencortex-tui
|
||||
passepartout-tui
|
||||
test_input.txt
|
||||
|
||||
# Generated artifacts (source of truth is .org)
|
||||
/skills/*.lisp
|
||||
/tests/*.lisp
|
||||
|
||||
429
README.org
429
README.org
@@ -1,407 +1,68 @@
|
||||
#+TITLE: OpenCortex: The Conductor of your Life Stack
|
||||
#+TITLE: Passepartout — Your Autonomous, Plain-Text Life Assistant
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :passepartout:ai:assistant:
|
||||
|
||||
#+CAPTION: A neurosymbolic AI agent framework for the 100-year Memex
|
||||
#+ATTR_HTML: :width 800
|
||||
#+HTML: <div style="display: flex; gap: 8px; flex-wrap: wrap; margin-bottom: 1em;">
|
||||
#+HTML: <img src="https://img.shields.io/github/v/tag/amrgharbeia/opencortex?label=version&style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/github/license/amrgharbeia/opencortex?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/Lisp-Common%20Lisp-blue?style=flat-square">
|
||||
#+HTML: <img src="https://img.shields.io/badge/docs-Org--mode-green?style=flat-square">
|
||||
#+HTML: </div>
|
||||
|
||||
*opencortex* is a minimalist, extensible AI agent framework designed to manage and continuously organize your personal knowledge base. It transforms a static collection of plaintext notes into a live, programmable [[https://en.wikipedia.org/wiki/Memex][Memex]]—an automated, personalized memory system where humans and AI collaborate in the exact same workspace.
|
||||
Passepartout is an AI assistant that runs in your terminal, reads and writes your Org-mode files, executes tasks through a verified safety gate, and works fully offline with local LLMs. Everything it knows is a folder of plain text files that you own.
|
||||
|
||||
* The Problem with Current AI Agents
|
||||
**One-line install:**
|
||||
|
||||
The current ecosystem of AI agents (typically built in Python or TypeScript) is overwhelmingly built on architectural choices that prioritize rapid prototyping over long-term reliability, security, and self-modification:
|
||||
|
||||
** 1. The Format Trap (Markdown & JSON)
|
||||
|
||||
Most agents force a painful translation layer. Humans write in Markdown, which lacks a strict Abstract Syntax Tree (AST)—a rigorous, nested representation of data that machines need to parse context reliably. Machines, in turn, output JSON, which is hostile for human thought and note-taking.
|
||||
|
||||
The result is a fractured workspace where the agent's memory and the human's memory are fundamentally incompatible. You cannot see what the agent sees. The agent cannot naturally work with your notes.
|
||||
|
||||
** 2. The Language Trap (Python & TypeScript)
|
||||
|
||||
Python and TypeScript are fantastic for gluing together APIs, but they are poorly suited for an agent that needs to safely read, write, and execute its own code at runtime. Their underlying structures are complex and opaque, making autonomous self-editing incredibly brittle and dangerous.
|
||||
|
||||
How do you trust an agent to modify its own Python code when Python's AST is so complex that even human programmers need IDEs to navigate it?
|
||||
|
||||
** 3. The Probabilistic Trap
|
||||
|
||||
Almost all modern agents rely entirely on /probabilistic/ reasoning. We ask an AI model to guess a shell command or write a Python script, and then blindly pipe that output to a terminal. Without a rigorous, /deterministic/ layer to formally verify the model's proposals before execution, these systems are fundamentally unsafe.
|
||||
|
||||
The model might hallucinate a command. It might output valid syntax that still does something dangerous. Without a deterministic gate, there's nothing between the guess and the terminal.
|
||||
|
||||
* The Vision: A Modern, Homoiconic Memex
|
||||
|
||||
openCortex abandons these fragile paradigms by returning to first principles and embracing two historically powerful technologies: *Org-mode* and *Common Lisp*.
|
||||
|
||||
** Org-mode: The Universal Language
|
||||
|
||||
Instead of wrestling with Markdown parsers or hiding data in opaque databases, openCortex mandates that *Org-mode is the native AST for both humans and machines.*
|
||||
|
||||
Org-mode is unique because it seamlessly brings together:
|
||||
- Human-readable prose
|
||||
- Structured metadata (properties and tags)
|
||||
- Lifecycle states (TODO/DONE/PLAN)
|
||||
- Executable code blocks
|
||||
|
||||
...all in a single plain-text file. The code is the data, and the data is the interface. When the agent "remembers" a fact or schedules a task, it writes an Org headline. You read exactly what the agent reads.
|
||||
|
||||
This is not a compromise—it's the design principle. The agent's memory and your memory are the same format, the same file, the same text.
|
||||
|
||||
** Common Lisp: The Engine of Self-Modification
|
||||
|
||||
There is a beautiful irony to openCortex: Lisp was invented in 1958 specifically to achieve Artificial Intelligence, and it has been waiting nearly 70 years for /this exact moment/ in computing history.
|
||||
|
||||
Lisp possesses a unique property called *Homoiconicity*: the primary representation of the program is also a data structure (nested lists) within the language itself. Because Lisp code /is/ Lisp data, it is trivially easy for an AI to generate, manipulate, and safely evaluate new tools at runtime.
|
||||
|
||||
This makes Lisp the ultimate, un-brittle language for a "self-writing" agent. The agent doesn't need an AST parser—it can simply read and write lists directly. The agent doesn't need a code generator—it can write Lisp that executes Lisp.
|
||||
|
||||
** The Probabilistic-Deterministic Loop
|
||||
|
||||
openCortex does not let AI models touch your system directly. Instead, it splits cognition into two distinct engines:
|
||||
|
||||
1. *The Probabilistic Engine (Neural/Dynamic):* Provides semantic understanding and dynamic reasoning. It utilizes a **Dynamic LLM Cascade** (OpenRouter, Ollama, Anthropic) to ensure the agent always has a "brain," falling back to local models if cloud services are unavailable.
|
||||
|
||||
2. *The Deterministic Engine (Logic/Safety):* Intercepts LLM proposals and formally verifies them against your security rules (the "Bouncer" pattern) before execution.
|
||||
|
||||
#+begin_src mermaid
|
||||
flowchart LR
|
||||
subgraph Probabilistic["Probabilistic Engine (LLM)"]
|
||||
LLM[LLM Call]
|
||||
end
|
||||
|
||||
subgraph Deterministic["Deterministic Engine (Skills)"]
|
||||
Policy[Policy Skill<br/>Constitutional invariants]
|
||||
Bouncer[Bouncer Skill<br/>Security vectors]
|
||||
Validator[Lisp Validator<br/>Structural verification]
|
||||
end
|
||||
|
||||
subgraph Actuation["Actuation"]
|
||||
Shell[Shell Actuator]
|
||||
TUI[TUI Client]
|
||||
Emacs[Emacs Gateway]
|
||||
end
|
||||
|
||||
LLM -->|Proposes action| Deterministic
|
||||
Policy -->|Checks| Bouncer
|
||||
Bouncer -->|Verifies| Validator
|
||||
Validator -->|Approves| Actuation
|
||||
Actuation -->|Feeds back| LLM
|
||||
#+begin_src bash
|
||||
curl -fsSL https://raw.githubusercontent.com/amrgharbeia/opencortex/main/passepartout | bash -s configure
|
||||
#+end_src
|
||||
|
||||
* Architecture: Thin Harness, Fat Skills
|
||||
Then ~passepartout tui~ to start chatting.
|
||||
|
||||
To guarantee long-term stability, openCortex enforces a strict architectural boundary inspired by the "thin harness, fat skills" philosophy.
|
||||
* Quick Start
|
||||
|
||||
** The Minimalist Harness
|
||||
You need SBCL (Common Lisp), git, and curl.
|
||||
|
||||
The Lisp microkernel is a thin, unbreakable harness strictly responsible for:
|
||||
|
||||
| Layer | Responsibility | Examples |
|
||||
|-------|----------------|----------|
|
||||
| *Perceive* | Normalize sensory input | CLI parsing, Emacs events, heartbeats |
|
||||
| *Reason* | Bridge neural and deterministic | LLM dispatch, response parsing, skill routing |
|
||||
| *Act* | Execute approved actions | Shell commands, tool calls, UI output |
|
||||
| *Memory* | Live object store | Org-object graph, snapshots, rollback |
|
||||
|
||||
What the harness does /not/ contain:
|
||||
- Policy rules (those are skills)
|
||||
- LLM integrations (those are skills)
|
||||
- Domain-specific functionality (those are skills)
|
||||
|
||||
** Literate, Single-File Skills
|
||||
|
||||
In openCortex, a Skill is simply a *single .org file* containing everything:
|
||||
- The documentation (prose explaining the skill's purpose)
|
||||
- The AI instructions (how the LLM should use this skill)
|
||||
- The deterministic code (Lisp that verifies/proposes actions)
|
||||
|
||||
When the system boots, it compiles these skills directly into the live Lisp image. Skills are hot-reloadable without restarting the daemon.
|
||||
|
||||
#+begin_src mermaid
|
||||
flowchart TD
|
||||
subgraph Skill["Skill: policy.org"]
|
||||
Docs["Documentation<br/>'This skill enforces...'"]
|
||||
AI["AI Instructions<br/>'When the user asks about...'"]
|
||||
Code["Deterministic Code<br/>'(defun policy-check-...)'"]
|
||||
end
|
||||
|
||||
subgraph Harness["Harness Core"]
|
||||
Package["package.lisp"]
|
||||
Loop["loop.lisp"]
|
||||
Perceive["perceive.lisp"]
|
||||
Reason["reason.lisp"]
|
||||
Act["act.lisp"]
|
||||
end
|
||||
|
||||
Code --> |Compiles into| Harness
|
||||
Harness --> |Runs| Pipeline
|
||||
Pipeline --> |Feeds| Skill
|
||||
#+begin_src bash
|
||||
git clone https://github.com/amrgharbeia/opencortex.git ~/projects/passepartout
|
||||
cd ~/projects/passepartout
|
||||
./passepartout configure # install deps, tangle, setup wizard
|
||||
passepartout tui # launch the terminal interface
|
||||
#+end_src
|
||||
|
||||
** The Metabolic Pipeline
|
||||
See [[file:docs/USER_MANUAL.org][User Manual]] for the full guide.
|
||||
|
||||
Every signal in openCortex moves through the same three-stage pipeline:
|
||||
* Why Passepartout
|
||||
|
||||
1. *Perceive:* Normalize raw input into a standardized Signal
|
||||
2. *Reason:* Generate a proposal via LLM, verify via skills
|
||||
3. *Act:* Execute the approved action, generate feedback
|
||||
** Your data stays yours.** No database, no vector store, no cloud silo. Your entire memory is a folder of Org files. You can read them with any text editor, search them with grep, and back them up however you like. If Passepartout stops existing, your data doesn't disappear.
|
||||
|
||||
#+begin_src mermaid
|
||||
sequenceDiagram
|
||||
participant User
|
||||
participant Gateway
|
||||
participant Perceive
|
||||
participant Reason
|
||||
participant Act
|
||||
participant User
|
||||
** The LLM can't do damage.** Every action the LLM proposes passes through a deterministic safety gate before it touches a file, runs a command, or sends a message. The LLM suggests; the gate decides. Hallucinations are blocked, not corrected after the fact.
|
||||
|
||||
User->>Gateway: "Write a note about X"
|
||||
Gateway->>Perceive: Raw message
|
||||
Perceive->>Perceive: Normalize to Signal
|
||||
Perceive->>Reason: Signal
|
||||
Reason->>Reason: LLM generates proposal
|
||||
Reason->>Reason: Skills verify proposal
|
||||
Reason->>Act: Approved action
|
||||
Act->>Act: Execute action
|
||||
Act->>Reason: Feedback signal
|
||||
Reason->>Perceive: New signal
|
||||
Perceive->>Gateway: Response
|
||||
Gateway->>User: "Done"
|
||||
#+end_src
|
||||
** Runs on your hardware.** Works fully offline with Ollama and local models. Cloud providers (OpenRouter, OpenAI, Anthropic, Groq, Gemini, DeepSeek, NVIDIA NIM) are optional add-ons.
|
||||
|
||||
** The Skill Registry
|
||||
** Written in Common Lisp.** Code is data. The agent reads its own source the same way it reads a text file — it parses, modifies, and hot-reloads its skills without restarting. One language from the kernel to the TUI to the build system.
|
||||
|
||||
Skills are discovered, sorted by dependency, and loaded at boot:
|
||||
* Architecture
|
||||
|
||||
#+begin_src mermaid
|
||||
flowchart LR
|
||||
subgraph Discovery["Skill Discovery"]
|
||||
Scan["Scan skills/ directory"]
|
||||
Sort["Topological sort by DEPENDS_ON"]
|
||||
end
|
||||
- [[file:org/core-loop.org][Metabolic Loop]] — Perceive → Reason → Act, the fundamental cognitive cycle
|
||||
- [[file:org/security-dispatcher.org][Dispatcher]] — 9-vector safety gate: secret scanning, path protection, shell safety, lisp validation, network exfiltration, privacy filtering
|
||||
- [[file:org/core-memory.org][Memory]] — Single-address-space object store with Merkle-tree integrity and snapshot rollback
|
||||
- [[file:org/core-skills.org][Skill Engine]] — 20 hot-reloadable skills loaded at boot, each an independent Org file
|
||||
- [[file:org/gateway-tui.org][TUI]] — Croatoan-based terminal interface connected via framed TCP protocol
|
||||
- [[file:org/gateway-llm.org][LLM Routing]] — Cascade dispatch through multiple providers with tier-based model selection
|
||||
|
||||
subgraph Loading["Skill Loading"]
|
||||
Validate["Validate syntax"]
|
||||
Jail["Jail in package namespace"]
|
||||
Register["Register in catalog"]
|
||||
end
|
||||
* Project Documentation
|
||||
|
||||
Scan --> Sort --> Validate --> Jail --> Register
|
||||
#+end_src
|
||||
|
||||
* The Three Data Stores
|
||||
|
||||
openCortex maintains three distinct representations of your knowledge:
|
||||
|
||||
| Store | Format | Location | Purpose |
|
||||
|-------|--------|----------|---------|
|
||||
| *Source of Truth* | Plaintext .org files | `~/memex/` | Human-readable, version-controlled |
|
||||
| *Active Brain* | RAM (Lisp hash tables) | Memory | Fast, live, queryable |
|
||||
| *Snapshots* | Binary .snap files | `~/.opencortex/` | Crash recovery, rollback |
|
||||
|
||||
The Active Brain is built from the Source of Truth on boot and kept in sync via:
|
||||
- Buffer updates from Emacs (when you edit)
|
||||
- Heartbeat snapshots (periodic persistence)
|
||||
- Graceful shutdown saves
|
||||
|
||||
* The Evolutionary Roadmap
|
||||
|
||||
openCortex's roadmap is designed working backwards from SOTA parity (V 1.0.0), guided by a critical analysis of four reference systems: OpenCode, Claude Code (leaked source), GBrain, and OpenClaw/Hermes. Every borrowed concept is reimplemented in pure Lisp. Every rejected pattern is documented.
|
||||
|
||||
** Non-Negotiable Identity
|
||||
- Pure Common Lisp + Org-mode. No JSON. No YAML. No external databases.
|
||||
- Single-address-space memory (Lisp hash tables in RAM — we *are* the memory).
|
||||
- "Thin harness, fat skills" — complexity lives at the edges, not the kernel.
|
||||
- One agent composed of many skills. No sub-agent topologies.
|
||||
- Plists everywhere — homoiconic communication between all components.
|
||||
|
||||
*** OpenCode: Borrowed / Rejected
|
||||
|
||||
| Feature | Decision | Rationale |
|
||||
|---------|----------|-----------|
|
||||
| Permission filtering before LLM sees tools | BORROW | Hook into =generate-tool-belt-prompt= to exclude denied tools. We have =:guard= but no pre-filter. |
|
||||
| Hook system (session start/end) | BORROW | Already designing event-orchestrator. Expose via =#+HOOK:= properties. |
|
||||
| Skills with YAML frontmatter | REJECT | Our Org-mode =:PROPERTIES:= + =#+FILETAGS= already do this. |
|
||||
|
||||
*** Claude Code: Borrowed / Rejected
|
||||
|
||||
| Feature | Decision | Rationale |
|
||||
|---------|----------|-----------|
|
||||
| ULTRAPLAN / structured task decomposition | BORROW (reimplement) | LLM already generates plist actions. Add task-tree skill that decomposes into Org-mode headline DAGs with terminal states. |
|
||||
| 43 integrated tools | BORROW (approach) | Start with ~3. Build more as skills. Keep =def-cognitive-tool= pattern. |
|
||||
| 4-tier permission chain (ask/allow/deny) | BORROW (concept) | Three-tier per-tool permission: ask/allow/deny stored in org-objects. |
|
||||
| Multi-agent hub-and-spoke topology | REJECT | We have one agent. Concurrency via bordeaux-threads (shared memory). Skills ARE the specialization — intra-process, not inter-process. |
|
||||
| Mailbox pattern for dangerous ops | REJECT | Jailed skill packages + Policy skill already provide isolation. Bouncer gate satisfies "worker can't self-approve". |
|
||||
|
||||
*** GBrain: Borrowed / Rejected
|
||||
|
||||
| Feature | Decision | Rationale |
|
||||
|---------|----------|-----------|
|
||||
| RESOLVER.md intent routing | BORROW (concept) | =find-triggered-skill= already does this. Enhance with multi-skill triggers for complex intents. |
|
||||
| Three search modes (keyword, hybrid, direct) | BORROW | Keep keyword + direct. Hybrid/vector via local Ollama embeddings — no external DBs. |
|
||||
| Memory segmentation (brain/agent/session) | BORROW (concept) | Extend org-object with =:scope= property: =:memex= (permanent), =:session= (ephemeral), =:project= (scoped). |
|
||||
| 20+ cron jobs for background work | BORROW (concept) | Heartbeat already does this. Enhance with Event Orchestrator's cron registry — pure Lisp. |
|
||||
| Sub-agent model routing for cost | BORROW (concept) | Our =*model-selector-fn*= already selects models. Extend to route by complexity tier. |
|
||||
| Postgres + pgvector | REJECT | Single-address-space hash tables. No external databases. |
|
||||
|
||||
*** opencortex-contrib: Integrate / Reject
|
||||
|
||||
| Skill | Decision | Rationale |
|
||||
|-------|----------|-----------|
|
||||
| self-fix + lisp-repair | INTEGRATE | Merge into =org-skill-self-edit=. Our memory has snapshot/rollback. Add =repair-file= as cognitive tool. |
|
||||
| event-orchestrator | INTEGRATE | Merge hooks + cron + routing into ONE skill. Our loop has no unified orchestration. |
|
||||
| formal-verification | INTEGRATE | =def-invariant= macro + =verify-action-formally= belong in =org-skill-policy.org= as additional checks. |
|
||||
| engineering-standards | INTEGRATE | Git-clean-p gate + "Commit Before Modify" belong in Policy. |
|
||||
| sub-agent-manager | REJECT | Redundant with BT threads. Our =defskill= pattern (trigger + probabilistic + deterministic) is intra-process specialization — same goal, zero process overhead. |
|
||||
| embedding-generator | BORROW | Ollama embeddings for semantic search — no external vector DB. |
|
||||
| playwright + web-research | DEFER | V 0.5.0. Browser automation via Python bridge. |
|
||||
|
||||
** Version Roadmap
|
||||
|
||||
*** v0.1.0: The Autonomous Foundation — CURRENT RELEASE ✅
|
||||
|
||||
The secure, auditable Lisp kernel. All core infrastructure in place.
|
||||
|
||||
| Component | Status | Notes |
|
||||
|-----------|--------|-------|
|
||||
| Perceive-Reason-Act pipeline | ✅ | 3-stage metabolic loop |
|
||||
| Skills engine with jailed loading | ✅ | defskill, topological sort, hot-reload |
|
||||
| Policy skill (6 invariants) | ✅ | Transparency, Autonomy, Bloat, Modularity, Mentorship, Sustainability |
|
||||
| Bouncer skill | ✅ | Command whitelist guard functions |
|
||||
| Memory (org-object + Merkle) | ✅ | Hash tables, snapshots, rollback |
|
||||
| Lisp validator skill | ✅ | Syntax validation before eval |
|
||||
| Scribe + Gardener skills | ✅ | Heartbeat-driven distillation + audit |
|
||||
| LLM gateway (OpenRouter + Ollama) | ✅ | Provider cascade |
|
||||
| Shell actuator | ✅ | Safe command execution |
|
||||
| Emacs bridge via Swank | ✅ | Point/buffer updates |
|
||||
| FiveAM test suite | ✅ | Memory, boot, pipeline, act, communication |
|
||||
| Credentials vault | ✅ | Encrypted storage |
|
||||
|
||||
*** v0.2.0: Self-Improvement + Local LLMs — NEXT
|
||||
|
||||
Priority: Self-editing is the foundation of all growth. Full org-mode manipulation makes the agent a true Emacs citizen.
|
||||
|
||||
| Feature | Source | Implementation |
|
||||
|---------|--------|----------------|
|
||||
| org-skill-self-edit (self-modification) | contrib self-fix + lisp-repair | Hook into =:syntax-error= events. Deterministic: auto-balance parens. Probabilistic: LLM surgical fix. Memory rollback on failure. |
|
||||
| org-skill-emacs-edit (full org manipulation) | Own need | Read org buffers, parse AST, create/update/delete headlines, set properties, manage TODO, handle links. Uses org-element. |
|
||||
| Local vector search (Ollama embeddings) | contrib embedding-generator | =generate-embeddings= via Ollama. Add =:vector= to org-object. Semantic search with cosine similarity. |
|
||||
| Tool permission tiers (ask/allow/deny) | Claude Code | Per-tool permission plist in org-object. =generate-tool-belt-prompt= filters denied tools. |
|
||||
| Skill hot-reload (=:reload-skill= tool) | Own need | Swap compiled skill files without breaking sockets. |
|
||||
|
||||
*** v0.3.0: Event Orchestration + Context Awareness
|
||||
|
||||
Priority: Unified control plane, deep project understanding before complex work.
|
||||
|
||||
| Feature | Source | Implementation |
|
||||
|---------|--------|----------------|
|
||||
| org-skill-event-orchestrator (hooks+cron+routing) | contrib event-orchestrator | Merge *hook-registry* + *cron-registry* + complexity classifier. Hooks via =#+HOOK:=. Three tiers: =:REFLEX= (no LLM), =:COGNITION= (light LLM), =:REASONING= (full LLM). |
|
||||
| org-skill-context-manager (project scoping) | contrib context-manager | Stack-based context. =push-context= / =pop-context=. Path resolution relative to current context. |
|
||||
| Memory scope segmentation | GBrain | =:scope= on org-objects: memex/session/project. Scope-aware retrieval. |
|
||||
| Model-tier routing (cost optimization) | GBrain | Heartbeat → smallest model. User input → medium. Complex reasoning → large. |
|
||||
| Slash commands (TUI ergonomics) | Own need | =M-x= style command palette. =/-= prefix. Commands defined in org-mode. |
|
||||
|
||||
*** v0.4.0: Long-Horizon Planning + Git Workflows
|
||||
|
||||
Priority: Real engineering work spans dozens of steps. Structured tracking, failure handling, course correction.
|
||||
|
||||
| Feature | Source | Implementation |
|
||||
|---------|--------|----------------|
|
||||
| org-skill-long-horizon (task tree DAG) | Claude Code ULTRAPLAN | Decompose tasks into Org-mode headline trees. Terminal states: =:done= / =:blocked= / =:stuck=. Parent summarises children. Branch pruning. |
|
||||
| org-skill-git-steward (version control) | contrib git-steward | Status, diff, commit, push, branch. Policy enforces commit-before-modify. |
|
||||
| TDD runner integration | contrib tdd-runner | FiveAM on file save. =:test-failure= events. Hook into self-fix for auto-repair. |
|
||||
| Deep Emacs integration | Own need | Full org-agenda awareness. Clock time, refile, archive. |
|
||||
|
||||
*** v0.5.0: Creator + Architect + GTD
|
||||
|
||||
Priority: Agent bootstraps itself. Creates skills autonomously, designs projects from PRDs, tracks work.
|
||||
|
||||
| Feature | Source | Implementation |
|
||||
|---------|--------|----------------|
|
||||
| org-skill-creator (autonomous skill generation) | contrib creator | LLM drafts complete skill org-file. Mandatory: syntax validation → jail-load → test → register. |
|
||||
| org-skill-architect (PRD → PROTOCOL) | contrib architect | Scan =:STATUS: FROZEN= PRDs. Generate Phase B PROTOCOL. |
|
||||
| org-skill-gtd (project tracking) | contrib gtd | Full GTD cycle. org-gtd v4.0 DAG (=:TRIGGER:=, =:BLOCKER:=). |
|
||||
| Consensus loop (multi-model agreement) | contrib consensus | Run multiple providers, compare results, detect disagreements. |
|
||||
| Web research (Playwright browsing) | contrib playwright | Headless Chromium via Python bridge. Gemini Web UI automation. |
|
||||
|
||||
*** v1.0.0: SOTA Parity
|
||||
|
||||
Feature-complete agent, competitive with commercial agents. All borrowed concepts reimplemented in pure Lisp.
|
||||
|
||||
| Area | Status | Notes |
|
||||
|------|--------|-------|
|
||||
| Self-improvement | ✅ v0.2.0 | Self-edit + lisp-repair = Claude Code self-debug parity |
|
||||
| Planning | ✅ v0.4.0 | Task tree DAGs = ULTRAPLAN equivalent |
|
||||
| Tool ecosystem | 🟡 v0.4.0 | 10+ tools (expand from 3) |
|
||||
| Context window | ✅ v0.3.0 | Semantic search + scope segmentation |
|
||||
| Safety | ✅ v0.1.0 | 6 Policy invariants + formal verification |
|
||||
| Multi-step tasks | ✅ v0.4.0 | Task trees with terminal states |
|
||||
| Code editing | ✅ v0.2.0 | Full file read/write via org manipulation |
|
||||
| Memory | 🟡 v0.2.0 | Add vector recall to org-object |
|
||||
| Emacs integration | ✅ v0.2.0 | Full org-mode control — exceeds Claude Code |
|
||||
| Autonomy | ✅ v0.1.0 | 100% local capable (Ollama) — exceeds Claude Code |
|
||||
|
||||
*** v2.0.0: Lisp Machine Emergence
|
||||
|
||||
The agent moves from "using Lisp" to "being Lisp."
|
||||
|
||||
| Feature | Implementation |
|
||||
|---------|----------------|
|
||||
| Lisp editor (Lish) | Org-mode as IDE. Org-babel for interactive evaluation. Full REPL in TUI. |
|
||||
| Shell replacement (Lish) | Lisp-based shell that speaks plists. Org-mode buffers as file system. |
|
||||
|
||||
*** v3.0.0: Neurosymbolic Maturity
|
||||
|
||||
| Feature | Implementation |
|
||||
|---------|----------------|
|
||||
| Deterministic planner | Planner as pure Lisp function. No LLM for scheduling. |
|
||||
| Self-correcting gates | Gates learn from false positives (user override patterns). |
|
||||
|
||||
*** v4.0.0: AI Stack Internalized
|
||||
|
||||
| Feature | Implementation |
|
||||
|---------|----------------|
|
||||
| Llama.cpp in Lisp | FFI binding to llama.cpp. No Python. |
|
||||
| Weights as sexps | Neural weights as Lisp data structures. |
|
||||
|
||||
*** v5.0.0: True Agency
|
||||
|
||||
| Feature | Implementation |
|
||||
|---------|----------------|
|
||||
| World models | Agent builds predictive models of user behavior, project dynamics, system state. |
|
||||
| Temporal reasoning | The agent reasons about time: scheduling, deadlines, elapsed duration. |
|
||||
| Goal persistence | Goals survive restarts. Long-term projects tracked in org-objects. |
|
||||
|
||||
** Design Principles
|
||||
|
||||
** 1. Radical Transparency
|
||||
|
||||
If you can't explain it, you can't do it. Every action must be auditable. Hidden reasoning is forbidden.
|
||||
|
||||
** 2. Autonomy First
|
||||
|
||||
Dependency on proprietary systems is debt. Prefer local, offline-capable solutions.
|
||||
|
||||
** 3. Zero Bloat
|
||||
|
||||
Complexity must be earned, not anticipated. The harness must remain minimal.
|
||||
|
||||
** 4. Modularity
|
||||
|
||||
The kernel must survive even if all skills fail. Complexity belongs at the edges.
|
||||
|
||||
** 5. Mentorship
|
||||
|
||||
Teaching is the highest form of assistance. Every action should increase capability.
|
||||
|
||||
** 6. Sustainability
|
||||
|
||||
Build for the 100-year horizon. Design for offline operation, local inference.
|
||||
|
||||
* Contributing
|
||||
|
||||
See [[file:docs/CONTRIBUTING.org][CONTRIBUTING.org]] for the Literate Granularity standard and skill creation guidelines.
|
||||
| Document | Answers |
|
||||
|----------|---------|
|
||||
| [[file:docs/USER_MANUAL.org][User Manual]] | How do I use it? |
|
||||
| [[file:docs/ARCHITECTURE.org][Architecture]] | How does it work inside? |
|
||||
| [[file:docs/DESIGN_DECISIONS.org][Design Decisions]] | Why was it built this way? |
|
||||
| [[file:docs/ROADMAP.org][Roadmap]] | Where is it going? When? |
|
||||
| [[file:docs/ROADMAP.org][TODO]] | Who is doing what? |
|
||||
| [[file:docs/CONTRIBUTING.org][Contributing]] | How do I contribute? |
|
||||
|
||||
* License
|
||||
|
||||
openCortex is released under the [[file:LICENSE][AGPLv3 license]].
|
||||
|
||||
See [[file:CLA.org][CLA.org]] for the Contributor License Agreement.
|
||||
Passepartout is released under the [[file:LICENSE][AGPLv3 license]].
|
||||
See [[file:CLA.org][CLA.org]] for the Contributor License Agreement.
|
||||
|
||||
90
docs/ARCHITECTURE.org
Normal file
90
docs/ARCHITECTURE.org
Normal file
@@ -0,0 +1,90 @@
|
||||
#+TITLE: Passepartout Architecture
|
||||
#+AUTHOR: Agent
|
||||
#+STARTUP: content
|
||||
|
||||
* The Four Quadrants
|
||||
|
||||
Passepartout divides cognition along two axes: **Foreground vs Background** (initiated by the user vs running autonomously) and **Probabilistic vs Deterministic** (LLM-driven vs pure Lisp logic).
|
||||
|
||||
| | Probabilistic (LLM) | Deterministic (Lisp) |
|
||||
|----------------|--------------------|---------------------|
|
||||
| **Foreground** | Chat responses, task execution, code generation | Shell execution, file I/O, safety gates, dispatcher checks |
|
||||
| **Background** | Scribe distillation, vector embedding, autonomous decisions | Heartbeat, cron jobs, memory auto-save, gateway polling |
|
||||
|
||||
The Probabilistic engine proposes. The Deterministic engine verifies and executes. No proposal from the LLM touches a file, runs a command, or sends a message without passing through at least one deterministic gate.
|
||||
|
||||
* Code Map
|
||||
|
||||
The project is organized into ~org/~ (source of truth) and ~lisp/~ (generated by tangle).
|
||||
|
||||
** Core pipeline (loaded by ASDF, committed to git)
|
||||
|
||||
| File | Purpose |
|
||||
|------|---------|
|
||||
| ~org/core-defpackage.org~ | Package definition and export list |
|
||||
| ~org/core-skills.org~ | Skill engine: ~defskill~ macro, topological sorter, jailed loading |
|
||||
| ~org/core-communication.org~ | Framed TCP protocol, actuator registry, daemon server |
|
||||
| ~org/core-memory.org~ | ~memory-object~ struct, Merkle hashing, snapshots, persistence |
|
||||
| ~org/core-context.org~ | Foveal-peripheral rendering, context assembly for LLM |
|
||||
| ~org/core-loop-perceive.org~ | Stage 1: normalize raw signals into pipeline format |
|
||||
| ~org/core-loop-reason.org~ | Stage 2: LLM proposal + deterministic verification |
|
||||
| ~org/core-loop-act.org~ | Stage 3: dispatch approved actions to actuators |
|
||||
| ~org/core-loop.org~ | Orchestration: process-signal, heartbeat, main entry point |
|
||||
| ~org/system-diagnostics.org~ | Boot-time health check, doctor CLI |
|
||||
|
||||
** Skills (loaded at runtime by the skill engine)
|
||||
|
||||
| Category | Files | Purpose |
|
||||
|----------|-------|---------|
|
||||
| **gateway-** | ~gateway-cli~, ~gateway-llm~, ~gateway-manager~, ~gateway-provider~, ~gateway-tui~ | External communication channels |
|
||||
| **security-** | ~security-dispatcher~, ~security-policy~, ~security-permissions~, ~security-vault~, ~security-validator~ | Safety and authorization |
|
||||
| **programming-** | ~programming-lisp~, ~programming-org~, ~programming-standards~, ~programming-literate~, ~programming-repl~ | Lisp and Org tooling |
|
||||
| **system-** | ~system-config~, ~system-archivist~, ~system-self-improve~, ~system-memory~, ~system-actuator-shell~, ~system-event-orchestrator~ | Background services |
|
||||
|
||||
* Pipeline Flow
|
||||
|
||||
Every signal moves through three stages:
|
||||
|
||||
```
|
||||
Signal → Perceive (normalize) → Reason (think + verify) → Act (dispatch)
|
||||
```
|
||||
|
||||
The signal is a plist: ~(:TYPE :EVENT :META (...) :PAYLOAD (:SENSOR :user-input :TEXT "..."))~
|
||||
|
||||
1. **Perceive** normalizes raw input from any gateway into a uniform signal
|
||||
2. **Reason** calls the LLM to generate a proposal, then runs the proposal through all registered deterministic gates (sorted by priority). If a gate rejects the proposal, the rejection trace feeds back to the LLM for self-correction (up to 3 retries)
|
||||
3. **Act** dispatches the approved action to the registered actuator (~:cli~, ~:tool~, ~:system~, ~:shell~, ~:telegram~, ~:signal~)
|
||||
|
||||
Each stage can produce feedback signals that loop back to Perceive (e.g., a tool-execute action produces a ~:tool-output~ event that becomes the next perception).
|
||||
|
||||
** Depth limiting
|
||||
|
||||
A depth counter prevents infinite loops. If a signal's depth exceeds 10, it is silently dropped. This is the circuit breaker for runaway recursive cycles.
|
||||
|
||||
* Skill Lifecycle
|
||||
|
||||
1. **Discovery:** ~skill-initialize-all~ scans the skills directory, globs for ~*.lisp~ files (excluding ~core-*~ files which are loaded by ASDF)
|
||||
2. **Sorting:** ~skill-topological-sort~ orders skills by their ~#+DEPENDS_ON:~ declarations
|
||||
3. **Loading:** Each skill is loaded into a jailed package (~passepartout.skills.<skill-name>~). The loader removes ~in-package~ forms, evaluates the remaining code in the jailed package, and exports symbols matching the skill's short name to ~passepartout~
|
||||
4. **Registration:** The skill's ~defskill~ call creates a ~skill~ struct in ~*skill-registry*~, registering its trigger function, probabilistic prompt generator, deterministic gate, and system-prompt augment
|
||||
5. **Triggering:** On each cognitive cycle, ~skill-triggered-find~ iterates the registry and returns the highest-priority skill whose trigger matches the context
|
||||
6. **Hot-reload:** A skill can be replaced at runtime by loading a new version into its jailed package — no restart needed
|
||||
|
||||
* Protocol Format
|
||||
|
||||
All communication between the daemon and its gateways (TUI, CLI, Emacs) uses length-prefixed plists over TCP:
|
||||
|
||||
```
|
||||
00002C(:TYPE :EVENT :PAYLOAD (:ACTION :handshake :VERSION "0.2.0"))
|
||||
```
|
||||
|
||||
The 6-character hex prefix encodes the payload length. The payload is a ~prin1~-serialized plist. ~*read-eval*~ is bound to nil on the receiving end to prevent code injection.
|
||||
|
||||
** Standard message envelope:
|
||||
|
||||
| Key | Value | Meaning |
|
||||
|-----|-------|---------|
|
||||
| ~:TYPE~ | ~:REQUEST~, ~:EVENT~, ~:RESPONSE~, ~:LOG~, ~:STATUS~ | Message category |
|
||||
| ~:META~ | plist | ~:SOURCE~, ~:SESSION-ID~, ~:reply-stream~ |
|
||||
| ~:PAYLOAD~ | plist | Action-specific data (~:SENSOR~, ~:ACTION~, ~:TEXT~) |
|
||||
| ~:DEPTH~ | integer | Recursion counter for loop prevention |
|
||||
@@ -1,8 +1,53 @@
|
||||
#+TITLE: Changelog
|
||||
#+STARTUP: content
|
||||
|
||||
* v0.2.1 — Rename, Safety, and Deployment (2026-05-02)
|
||||
This release renames the project to Passepartout, adds content-level safety gates, professionalizes deployment, and documents every function with full explanatory prose.
|
||||
|
||||
** Project Rename
|
||||
- **Passepartout:** Project renamed from OpenCortex to Passepartout. All files, packages, functions, and environment variables updated.
|
||||
- **Org/lisp split:** Source of truth lives in ~org/~, tangled to ~lisp/~. Core files committed, skills generated at configure time.
|
||||
- **31 org files:** Every file renamed to ~category-subject.org~ convention. Harness and skills unified under one directory.
|
||||
|
||||
** Safety
|
||||
- **Secret Exposure Gate:** Content scanning for API keys, PEM blocks, PGP keys, credentials, and tokens in all outgoing text.
|
||||
- **Path Protection:** File reads blocked for ~.env~, SSH keys, PEM/PGP, cloud configs, and credential stores.
|
||||
- **Shell Safety:** Destructive commands (~rm -rf /~, ~dd~, ~mkfs~, ~shred~) and injection patterns (backtick, ~$()~) blocked with timeout and output limits.
|
||||
- **Lisp Validation Gate:** Writes to ~.lisp~ and ~.org~ files validated for syntax errors before they reach disk.
|
||||
- **REPL Verification Lint:** Warns if defuns are written without REPL prototyping.
|
||||
|
||||
** Deployment
|
||||
- **Multi-distro:** Automatic detection of Debian vs Fedora, correct package names and managers.
|
||||
- **systemd service:** User-level auto-start on boot via ~passepartout install service~.
|
||||
- **Backup/Restore:** ~passepartout backup~ and ~passepartout restore~ commands.
|
||||
- **Docker:** Updated to ~debian:trixie-slim~, fixed build context.
|
||||
- **CI/CD:** GitHub Actions workflows for lint, test, and release. Gitea deploy workflow fixed.
|
||||
|
||||
** Engineering Process
|
||||
- **REPL-first Lifecycle:** Two-track workflow: Org-first for prose and tests, REPL-first for implementation. Every function prototyped in the REPL before reaching Org.
|
||||
- **Verification Loop:** Bouncer rejects bad lisp; rejection trace feeds back to LLM for self-correction.
|
||||
- **System-prompt-augment:** Skills can inject domain-specific mandates into the LLM prompt via ~:system-prompt-augment~.
|
||||
|
||||
** Documentation
|
||||
- **Literate Prose Restored:** Every Org file now has an Architectural Intent overview and explanatory prose before each function block, following the style established in the v0.1.0 era.
|
||||
- **AGENTS.md:** Thinned to a routing layer — the skill org files are authoritative.
|
||||
|
||||
** Contributors
|
||||
- **gitignore:** ~skills/*.lisp~ and ~tests/*.lisp~ as generated artifacts (source of truth is ~.org~).
|
||||
- **DeepSeek and NVIDIA NIM:** Added as LLM providers (OpenAI-compatible). Use ~DEEPSEEK_API_KEY~ and ~NVIDIA_API_KEY~ env vars.
|
||||
|
||||
* v0.2.0 - Interactive Refinement (2026-04-29)
|
||||
This release focuses on professionalizing the environment and enhancing the agent's structural capabilities.
|
||||
|
||||
** Features
|
||||
- **Enhanced Lisp/Org Utilities:** Structural editing, REPL evaluation, and automated formatting to ensure code integrity.
|
||||
- **Namespace Standardization:** Refactored utilities into =utils-org= and =utils-lisp= for predictable discovery.
|
||||
- **Autonomous Mandates:** Implemented =GEMINI.md= for local agentic enforcement of engineering standards.
|
||||
- **Onboarding Wizard:** Modular Lisp setup for multiple LLM providers.
|
||||
- **Professional TUI:** Styled, scrollable interface with improved diagnostics.
|
||||
|
||||
* v0.1.0 - The Autonomous Foundation (2026-04-20)
|
||||
This is the initial MVP release of the ~opencortex~. It establishes a secure, auditable Lisp kernel for a personal operating system.
|
||||
This is the initial MVP release of the ~passepartout~. It establishes a secure, auditable Lisp kernel for a personal operating system.
|
||||
|
||||
** Features
|
||||
- **Unified Envelope Architecture:** Actuator-agnostic protocol that decouples routing metadata from cognitive payloads, ensuring all clients (TUI, Emacs, CLI, Matrix) are treated as equal citizens.
|
||||
@@ -12,12 +57,12 @@ This is the initial MVP release of the ~opencortex~. It establishes a secure, au
|
||||
- **The Bouncer:** Last-mile deterministic security gate with Deep Packet Inspection for secrets and network exfiltration.
|
||||
- **Autonomous Scribe:** Background distillation worker that turns daily journal entries into evergreen Zettelkasten notes. Verified to distill atomic concepts autonomously.
|
||||
- **Autonomous Gardener:** Heartbeat-driven worker that repairs broken links and identifies orphaned nodes in the Memex graph.
|
||||
- **Unified Onboarding:** Single-command installation (~opencortex.sh~) with Docker support, OS detection, and automated dependency resolution.
|
||||
- **Unified Onboarding:** Single-command installation (~passepartout.sh~) with Docker support, OS detection, and automated dependency resolution.
|
||||
- **Channel-Aware TUI:** Interactive Croatoan-based terminal client with clean, human-readable formatting for tool results and system logs.
|
||||
- **CLI Gateway:** Local TCP socket server for pipe-friendly interaction and frictionless first contact.
|
||||
|
||||
** Licensing & Community
|
||||
- **AGPLv3 License:** OpenCortex is now officially licensed under the GNU Affero General Public License v3.0.
|
||||
- **AGPLv3 License:** Passepartout is now officially licensed under the GNU Affero General Public License v3.0.
|
||||
- **Contributor License Agreement:** Implemented a broad CLA (~CLA.org~) for long-term project sustainability.
|
||||
|
||||
** Architectural Shift
|
||||
|
||||
@@ -1,10 +1,10 @@
|
||||
#+TITLE: Contributing to OpenCortex
|
||||
#+AUTHOR: OpenCortex Contributors
|
||||
#+TITLE: Contributing to Passepartout
|
||||
#+AUTHOR: Passepartout Contributors
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :docs:contributing:
|
||||
|
||||
* Philosophy
|
||||
OpenCortex is built on a "Zero-Bloat" mandate. The core kernel is mathematically pure, pushing all peripheral logic, API integrations, and routing to hot-reloadable "Skills".
|
||||
Passepartout is built on a "Zero-Bloat" mandate. The core kernel is mathematically pure, pushing all peripheral logic, API integrations, and routing to hot-reloadable "Skills".
|
||||
|
||||
* Literate Granularity
|
||||
We strictly adhere to Literate Programming using Org-mode.
|
||||
@@ -14,7 +14,7 @@ We strictly adhere to Literate Programming using Org-mode.
|
||||
- Every architectural decision, constraint, and implementation detail must be documented alongside the code in the `.org` file.
|
||||
|
||||
* Skill Creation Standard
|
||||
Skills are the building blocks of OpenCortex. They reside in the `skills/` directory.
|
||||
Skills are the building blocks of Passepartout. They reside in the `skills/` directory.
|
||||
|
||||
A skill must define:
|
||||
1. *Trigger*: A lambda determining if the skill should activate based on the context.
|
||||
@@ -40,5 +40,5 @@ All inter-process communication occurs via the Unified Envelope. Do not use lega
|
||||
1. Ensure your working tree is clean.
|
||||
2. Write tests for your skill in `tests/`.
|
||||
3. Tangle all files.
|
||||
4. Run the test suite: `sbcl --eval "(asdf:test-system :opencortex)"`.
|
||||
4. Run the test suite: `sbcl --eval "(asdf:test-system :passepartout)"`.
|
||||
5. Submit a PR outlining the architectural intent and the specific Literate changes.
|
||||
460
docs/DESIGN_DECISIONS.org
Normal file
460
docs/DESIGN_DECISIONS.org
Normal file
@@ -0,0 +1,460 @@
|
||||
# Passepartout Design Decisions
|
||||
|
||||
This document captures the rationale behind key architectural choices. It is not a specification - it is a thinking medium for future architects and contributors who need to understand why the system is built this way, not just how.
|
||||
|
||||
* Multi-Agent by Default is a Smell
|
||||
:PROPERTIES:
|
||||
:ID: design-multi-agent-default
|
||||
:END:
|
||||
|
||||
The AI industry has developed an intuition toward multi-agent systems as the default solution to hard problems. Multiple agents spawn, delegate, coordinate, debate, and consensus their way toward solutions. This pattern is compelling in demos and genuinely useful in specific contexts - but it has become a default assumption that warrants scrutiny.
|
||||
|
||||
When context windows grew expensive and task complexity increased, the response was natural: split the problem across agents, each handling a slice. But this architectural choice carries hidden costs that are rarely acknowledged in the enthusiasm of implementation.
|
||||
|
||||
**The synchronization tax** is the most immediate burden. Each agent operates with partial information, and maintaining coherence requires continuous state reconciliation. Tokens and processing cycles are spent not on the task itself, but on protocol overhead - who holds what, who decided what, who is correct when they disagree.
|
||||
|
||||
**Fragmented context** is the deeper problem. When Agent A writes a function and Agent B modifies a type it depends on, neither has the full picture. Integration failures emerge not from individual incompetence but from systemic communication gaps. Single-agent systems avoid this entirely: one brain holds the complete model, every decision is made with full visibility.
|
||||
|
||||
**Audit trails become complex** in multi-agent systems. A decision traced through a single-agent system has a clean, linear history. A decision traced through a multi-agent system branches and forks, with each agent's reasoning partially overlapping and partially conflicting.
|
||||
|
||||
None of this is to say multi-agent systems are never appropriate. Embarrassingly parallel workloads - scanning ten thousand files, processing batch jobs - benefit from parallelism regardless of context. When distinct expertises are required and cannot coexist in one model, delegation makes sense. In adversarial scenarios where conflicting goals are features, multi-agent architectures shine.
|
||||
|
||||
But the default assumption that complex reasoning tasks are best solved by multiple agents is unproven and likely wrong for the engineering domain. Claude Code is a single-agent system. It handles 50-file refactors, debugs complex stack traces, writes tests, and navigates large codebases. The assumption that you need five agents to do what one well-designed agent can do is an industry habit, not a technical necessity.
|
||||
|
||||
Passepartout is single-agent by default not from limitation but from conviction: for reasoning-heavy work where coherence matters, a unified memory space and single decision-making locus are architectural assets, not constraints.
|
||||
|
||||
* The Unified Memory Argument
|
||||
:PROPERTIES:
|
||||
:ID: design-unified-memory
|
||||
:END:
|
||||
|
||||
If single-agent architecture is the decision, unified memory becomes the mechanism that makes it viable. The critical question is not "how many agents" but "how does the agent manage context without saturating."
|
||||
|
||||
Context window limits are largely a symptom of lazy architecture. The default approach - stuff everything in, hope the model figures it out - works poorly at scale. A more principled approach inverts the problem: the system should hold effectively infinite context, with the active window kept lean through intelligent management.
|
||||
|
||||
**Lazy loading** is the core technique. When an agent needs information about a function, it does not load the entire codebase. It loads precisely what the function does. Context stays lean - 2,000 to 4,000 tokens - while the full context remains accessible through retrieval.
|
||||
|
||||
**Compaction events** are scheduled during idle cycles. The system extracts new facts from active context and writes them to permanent storage. Active context is wiped clean, not because space ran out, but because the information has been preserved in a form that can be retrieved when relevant.
|
||||
|
||||
**Org-mode as externalized memory** solves the persistence problem elegantly. Every decision, every note, every task lives in plain text files the user already owns. The agent does not maintain a separate database. It queries files it can already access, modifies files it already owns.
|
||||
|
||||
**Retrieval is the key primitive.** Semantic search across Org files finds relevant nodes. The agent does not hold the full context - it holds pointers to context, loaded on demand. This is how a single agent handles tasks that would saturate a naive multi-megabyte context window.
|
||||
|
||||
The unified memory argument is not that infinite context is free. It is that with proper architecture, effective infinite context is achievable without the synchronization and fragmentation costs of multi-agent systems.
|
||||
|
||||
* The Probabilistic-Deterministic Split
|
||||
:PROPERTIES:
|
||||
:ID: design-probabilistic-deterministic
|
||||
:END:
|
||||
|
||||
The architecture divides cognition into two fundamentally different reasoning systems. This is not arbitrary engineering but a structural response to a fundamental truth: probabilistic systems will hallucinate, and you cannot build reliable autonomy on an unreliable foundation.
|
||||
|
||||
An LLM is a statistical engine. It generates outputs based on patterns in training data. It is remarkable at translation, generation, pattern matching, and fuzzy reasoning. It can take messy human intent and produce structured queries. It can take structured results and produce natural language. It is, in the terminology of the system, the creative brain.
|
||||
|
||||
But it cannot be trusted. Not because it is poorly designed or insufficiently trained, but because hallucination is a fundamental property of probabilistic inference. The model generates the most likely continuation, not the correct one. Given sufficient context, the most likely continuation is correct. Given novel context, it is often wrong in confident-sounding ways.
|
||||
|
||||
The deterministic engine addresses this by being what the probabilistic engine is not: mathematically rigorous, formally verifiable, and incapable of hallucination by design. It operates on explicit symbolic representations - lists, property lists, knowledge graphs - not on floating-point activations. When it evaluates a path confinement check, it returns true or false, not a probability distribution.
|
||||
|
||||
The division of labor is architectural. The LLM handles the fuzzy interface between human language and structured representation. It translates what the user wants into what the system can reason about. The deterministic engine receives those structured representations and evaluates them against formal invariants. It decides whether to execute, not whether the translation was semantically plausible.
|
||||
|
||||
This separation is the source of Passepartout's safety guarantee. Other agents add "guardrails" as an afterthought - a layer of filtering around a dangerous core. Passepartout makes the division explicit: the LLM never touches the file system, never executes a command, never modifies memory. It generates proposals. The deterministic engine evaluates and executes. The dangerous operations are never in the probabilistic path.
|
||||
|
||||
The split also explains why the system gets safer over time without the LLM improving. The deterministic engine accumulates rules. The LLM proposes actions, the engine evaluates them against a growing rule set. Early versions block obvious dangers. Later versions block sophisticated attacks that were previously unknown. The safety grows logarithmically with the number of interactions, not linearly with model capability.
|
||||
|
||||
* Homoiconicity as Foundation
|
||||
:PROPERTIES:
|
||||
:ID: design-homoiconicity
|
||||
:END:
|
||||
|
||||
Common Lisp is homoiconic: code and data share the same representation. A Lisp program is a list, and a list is a Lisp program. This is usually presented as a curiosity, an interesting property that enables macros. In Passepartout, it is the foundational enabling property of the entire self-modification architecture.
|
||||
|
||||
When code is data, the agent can read its own source the same way it reads a text file or an Org buffer. There is no AST parser required, no external tool to extract the function object from the running image. The agent evaluates (read-from-string source) and the result is executable Lisp. The representation it manipulates is the same representation that the runtime executes.
|
||||
|
||||
This is not true of most languages. In Python, the agent can inspect an AST through the ast module, but that AST is a foreign object - a data structure that represents code but is not code itself. The agent can see that a function takes certain arguments and returns a certain type, but it cannot treat the AST as a live object it can modify and re-evaluate. In C, the agent cannot inspect its own compiled machine code at all.
|
||||
|
||||
In Lisp, the distinction between code and data is a convention, not a barrier. The agent's skills are lists. The agent can take a skill, extract a function definition, modify the body, wrap it in a new list, and evaluate it. The modification is surgical: it changes exactly what it intends to change, with no risk of corrupting adjacent state, because the representation is a tree that the runtime understands natively.
|
||||
|
||||
Runtime introspection is therefore native. The agent does not need a debugger API or a reflection protocol. It operates on its own code as data because its own code is data. (describe 'function-name) returns the function's documentation. (function-lambda-list 'function-name) returns its parameters. (macroexpand-1 '(defskill ...)) shows what the macro produces. There is no impedance mismatch between the agent's reasoning and the system's representation.
|
||||
|
||||
Self-modification is the practical consequence. The agent can detect an error, locate the erroneous function, generate a corrected version, and hot-reload it into the running image. The correction is not applied to a file that requires a restart - it is applied to the live object that the system is currently executing. This is what makes the self-editing skill viable: the agent can fix itself without stopping.
|
||||
|
||||
In v3.0.0, when the symbolic engine takes over the reasoning core, homoiconicity becomes the bridge between the neural and symbolic layers. The neural engine generates proposals as s-expressions. The symbolic engine evaluates them against formal constraints. The result is a modification that is simultaneously a data structure the symbolic engine can analyze and code the runtime can execute. The two representations are identical by construction.
|
||||
|
||||
This is the technical meaning of "Lisp as Governor": not just that Lisp orchestrates the other components, but that the representation of the system is uniform and inspectable at every level. There is no hidden state, no opaque machine code, no representation that the agent cannot reach into and modify. The system is legible to itself by design.
|
||||
|
||||
**Self-Modification Without Boundaries**
|
||||
|
||||
Other systems that support self-editing draw a line between the core and the skills. Hermes can modify its skills at runtime, but the core harness is protected - editing it requires a restart because the core is treated as privileged code that cannot be safely modified while running.
|
||||
|
||||
Passepartout has no such boundary. The "thin harness, fat skills" distinction describes where complexity lives, not where authority flows. The harness is small by design, but it is not privileged. The agent can read and write any part of the system - including the very code that is currently executing - without restarting.
|
||||
|
||||
This is only possible because Lisp code is mutable data at runtime. In a compiled language, the machine code for a running function is locked in memory, protected by the call stack, impossible to modify safely. In Lisp, the function object is a list you can modify with =setf=. When the agent changes a harness function, the running image immediately reflects the change. The next invocation uses the new code. There is no restart, no special boot mode, no distinction between development and production.
|
||||
|
||||
The implications extend beyond convenience. A system that cannot modify its own core is a system that has limits on its own adaptability. It can learn skills but not improve its own structure. It can grow but not evolve. Passepartout's lack of a core boundary means the system can improve its own reasoning engine, fix bugs in its own cognition, and evolve its own architecture - all while continuing to operate.
|
||||
|
||||
This is the final expression of homoiconicity: not just that code is readable as data, or that skills are modifiable, but that the entire system - including the parts that other systems protect - is open to modification. There is no ceiling on self-improvement. The agent can rewrite the very code that rewrites itself.
|
||||
|
||||
**Lisp and the AI Dream**
|
||||
|
||||
Lisp was invented in 1958 by John McCarthy with artificial intelligence explicitly in mind. Its design - code as data, runtime mutation, symbols and lists as first-class constructs - was shaped by the belief that a truly intelligent machine would need to reason about and modify its own reasoning. For decades, Lisp machines were the closest thing to thinking machines that existed.
|
||||
|
||||
Then the AI winter came. Symbolic AI fell out of favor. Statistical learning and neural networks dominated. Lisp was relegated to niche applications and academic curiosity. The machine that was designed for AI was never used for the task it was designed for.
|
||||
|
||||
Six decades later, neural networks have arrived at the problem from a different direction. They can learn and generalize, but they hallucinate, cannot explain their reasoning, and cannot safely modify themselves. The neuro-symbolic synthesis - combining neural pattern recognition with symbolic reasoning - is recognized as the path toward AI that is both powerful and trustworthy.
|
||||
|
||||
Lisp's time may finally have come. Not as a replacement for neural networks, but as the governor that makes them safe - the symbolic engine that verifies what the neural engine proposes, the homoiconic substrate that allows the system to inspect, modify, and improve its own reasoning. The machine that was designed for AI in 1958 may be the exact machine needed for AI in 2026 and beyond.
|
||||
|
||||
* Org-Mode as Unified AST
|
||||
:PROPERTIES:
|
||||
:ID: design-org-unified-ast
|
||||
:END:
|
||||
|
||||
Passepartout makes a bet that most systems consider too expensive to place: that humans and machines should share the same file format. That bet is Org-mode.
|
||||
|
||||
Most systems separate human-readable notes from machine-readable data. The user writes Markdown. The system stores it, indexes it, searches it. But internally, the system maintains its own model - a database, an object store, a knowledge graph - that is disconnected from the Markdown. When the user dies or leaves, the Markdown survives but the model must be reconstructed.
|
||||
|
||||
Passepartout refuses this separation. The Org file is not a representation of the data. The Org file IS the data. The same text that the user reads and edits is what the system parses and operates on. org-element reads an Org buffer and returns a tree structure that is the direct Lisp representation of the file's content.
|
||||
|
||||
This has several profound implications.
|
||||
|
||||
First, there is no translation layer between human and machine. When the agent writes a skill, it writes Org text that is immediately readable by the human who owns the file. When the human writes a note, it is immediately accessible to the agent as a native data structure. The communication is not mediated by a schema or an import/export process.
|
||||
|
||||
Second, the format is genuinely readable by both parties, not just technically accessible. Org-mode's syntax is human-friendly: headlines begin with asterisks, properties live in drawers, tags are labels after colons. The human does not have to understand the full Org specification to read what the agent wrote. The agent does not have to handle edge cases in human notation.
|
||||
|
||||
Third, the format is stable across decades. Org-mode has been in active development since 2003. The files written today will be readable by Org-mode in 2040. There is no schema migration, no database upgrade, no vendor lock-in. The human's notes survive the system.
|
||||
|
||||
Fourth, the format is universally available. Org-mode is free software. The files are plain text. There is no proprietary format to decode, no application to purchase, no cloud service to access.
|
||||
|
||||
Fifth, the format is header-aware and sparse-tree capable. Org-mode's headline hierarchy is not just formatting - it is a semantic structure the system can query. The agent can retrieve only the relevant subtree under a heading, ignoring the rest of the file. This is fundamentally different from Markdown, where the entire file must be loaded or the retrieval logic must parse and filter at the string level.
|
||||
|
||||
Sparse tree retrieval is the key to efficient context management. When the agent needs information about the =openctl-db= function, it queries for the =openctl-db= subtree specifically. It receives exactly the code, documentation, and metadata under that heading - nothing more. The context stays lean not because the file was pre-split but because the retrieval is structural. In a Markdown system, the agent either loads the entire file (expensive, noisy) or relies on imprecise grep-like search (fragile, loses hierarchy). In Org-mode, retrieval is precise, hierarchical, and cheap. The heading boundary is the access boundary.
|
||||
|
||||
Sixth, Org-mode unifies what every other format fragments. A single Org file contains the headline hierarchy, prose documentation, source code blocks with live evaluation, tags for categorization, metadata in property drawers, TODO state for task management, timestamps and deadlines, and links to other nodes. Markdown cannot express TODO state without external tools. JSON cannot contain prose. YAML cannot embed runnable code. Each format serves one purpose; Org-mode serves all of them. When the agent reads a skill file, it reads documentation, code, dependencies, metadata, and task state in one parseable structure. When the human reads the same file, they see the same information rendered in a human-friendly form. No other format achieves this unification without maintaining parallel files or external databases.
|
||||
|
||||
Seventh, a skill lives in one Org file, not a directory. The standard pattern for a software project is a directory containing =README.md=, =package.json=, =src/main.py=, =src/utils.py=, =tests/test_main.py=, =scripts/deploy.sh=, and =config.yaml=. Each file type is isolated by convention: prose lives in README, code lives in src, tests in tests, configuration in config. This fragmentation means the skill is not a single object the system can reason about - it is a collection of files the system must assemble. Passepartout's skills violate this convention deliberately. Each skill is one Org file. The file contains the skill's documentation, the skill's code, the skill's metadata, the skill's TODO state, and the skill's dependencies on other skills. There is no directory to navigate, no external files to locate, no risk that the README describes behavior that the code does not implement. The skill is a single atomic unit: readable by human and machine, editable by both, versionable as one entity.
|
||||
|
||||
The unified format is what makes the memory architecture work. The agent's memory is not a database that the user cannot inspect. It is a folder of Org files that the user can read, edit, and understand. The agent manipulates these files directly, using the same tools the user would use. There is no hidden state, no shadow database, no model that differs from the source.
|
||||
|
||||
This is what "sovereignty" means in technical terms: the user owns the data in a format they can access, and the agent operates on the data in the same format they own.
|
||||
|
||||
* Literate Programming as Discipline
|
||||
:PROPERTIES:
|
||||
:ID: design-literate-programming
|
||||
:END:
|
||||
|
||||
The decision to use Org-mode as the source of truth for code, not just documentation, is not a ceremonial preference. It is a constraint mechanism that enforces better engineering habits at the cost of convenience.
|
||||
|
||||
The traditional development workflow is: write code, write comments, commit. The literate programming workflow is: write prose, write code, commit the Org. The order matters. The prose must come first not because of style guidelines but because the act of explaining what a function does before writing it forces clarity of thought that editing code directly does not.
|
||||
|
||||
When you must write a paragraph describing what a function does before you write the function, you discover the cases you have not considered. You find the edge conditions that are ambiguous. You realize that the function's name does not match its behavior, or that its behavior does not match your intent. The friction is not a bug - it is the mechanism by which thinking is enforced.
|
||||
|
||||
The one-function-per-block rule enforces granularity. A function that cannot be explained in a paragraph is a function that is doing too much. The block boundary is not aesthetic - it is architectural. It prevents the drift toward monolithic functions that accumulate responsibilities over time and become untestable, unmaintainable, and incomprehensible.
|
||||
|
||||
The tangle step enforces source-of-truth discipline. The .lisp file is generated from the Org file. This means the Org file cannot drift from the implementation. If the implementation changes, the Org must be updated to match. If the Org describes behavior that the implementation does not perform, the tangle produces code that does not match the Org description. Either way, inconsistency is visible and recoverable.
|
||||
|
||||
The evaluation gate enforces correctness. Every block can be evaluated independently in a running Lisp image. This means syntax errors are caught at authorship time, not at integration time. The function that compiles in isolation but fails in context is the function whose context dependencies were never made explicit. The evaluation gate forces those dependencies to surface.
|
||||
|
||||
Together, these constraints create a development experience that is slower in the small and faster in the large. Writing a new function takes longer because you must explain it. But debugging, maintaining, and extending the codebase is faster because every function has a human-readable explanation of its intent, every function is testable in isolation, and every function's source is always synchronized with its documentation.
|
||||
|
||||
The literate programming discipline is not about producing documentation. It is about producing code whose correctness has been verified by the act of explaining it.
|
||||
|
||||
* The Bouncer as Learning System
|
||||
:PROPERTIES:
|
||||
:ID: design-bouncer-learning
|
||||
:END:
|
||||
|
||||
The Bouncer begins as a static guard - a set of rules that block obviously dangerous actions. But defining "obviously" is the hard problem. The agent encounters situations the rules do not anticipate. The Bouncer must grow.
|
||||
|
||||
The human-in-the-loop exception is the seed. When the LLM proposes an action the Bouncer does not recognize, the system does not default to blocking or allowing. It suspends. It writes the proposed action to an Org buffer in a format the human can read and understand. The human reviews and approves or denies. The Bouncer observes the decision.
|
||||
|
||||
From this single observation, the Bouncer extracts a rule. Not merely "allow this specific action" but "allow this class of actions parameterized by these dimensions." The human approved a write to ~/projects/myapp/src/core.clj. The Bouncer generalizes: writes to ~/projects/*/src/*.lisp are approved for this session, or for this project, or indefinitely depending on the context and the user's pattern of decisions.
|
||||
|
||||
Shadow mode is where rules are tested before deployment. When the Bouncer encounters a novel situation and is uncertain, it can run the proposed action in a simulated environment. It observes the side effects - what files would be modified, what processes would be spawned, what network calls would be made. If the simulation produces dangerous side effects, the rule is discarded. If it appears safe, the rule is added to the active set with a confidence rating.
|
||||
|
||||
Formal verification is where the learned rules are checked against invariants. The Bouncer's rules are not merely patterns observed from human behavior. They are formulas in a logic that the system can reason about. A rule that would enable path traversal is not discarded because it was observed to be safe in prior instances - it is discarded because it violates the path-confinement invariant by construction.
|
||||
|
||||
The Bouncer becomes, over time, not a guard that blocks bad actions but a reasoning system that understands why actions are good or bad. Early versions learn from human decisions. Later versions learn from their own logical analysis. The human's role transitions from approver to auditor to, eventually, unnecessary oversight.
|
||||
|
||||
This is the bootstrap. The system begins dependent on human judgment because it has no basis for judgment of its own. Through accumulated decisions, it constructs a model of what is permitted and why. That model is the foundation for the deterministic symbolic engine that in v3.0.0 takes over the reasoning that the Bouncer learned to perform.
|
||||
|
||||
* Passepartout as a Function in Time
|
||||
:PROPERTIES:
|
||||
:ID: design-trajectory
|
||||
:END:
|
||||
|
||||
The system is not static. Passepartout is defined not just by its current state but by its trajectory - how its cognitive architecture evolves over versions, with each phase reducing probabilistic surface area while increasing deterministic control.
|
||||
|
||||
**v0.1.0: The Probabilistic Foundation**
|
||||
|
||||
The agent begins by relying heavily on the neural engine. The LLM translates messy human intent into structured queries, generates code, proposes solutions. The Bouncer is present but thin - it blocks obviously dangerous actions, verifies path confinement, enforces basic invariants. Most reasoning is probabilistic because the symbolic infrastructure does not yet exist to do otherwise.
|
||||
|
||||
At this stage, Passepartout is similar to other LLM-based agents. The key difference is the gate is already there - the architecture assumes the LLM will hallucinate and structures safety accordingly.
|
||||
|
||||
**v0.2.0 through v0.5.0: The Bouncer Learns**
|
||||
|
||||
Each version expands the deterministic layer. The Bouncer writes rules from approved exceptions. Shadow mode runs trial executions. Tool permission tiers mature from simple allow/deny to nuanced context-aware policies. The agent becomes less likely to attempt dangerous actions not because it is smarter but because the guard has more complete information.
|
||||
|
||||
This is the bootstrapping phase. The system learns by watching itself and its user. Every blocked action becomes a rule. Every approved exception becomes a pattern. The symbolic layer grows at the probabilistic layer's expense.
|
||||
|
||||
**v0.6.0 through v0.7.0: The Architecture Crystallizes**
|
||||
|
||||
Skills become more deterministic. The agent learns to write its own skills - first drafts generated by the LLM, but verified and refined by the symbolic engine. Self-editing improves. The REPL becomes a first-class cognitive substrate - code is not just written but verified, iterated, tested before committing.
|
||||
|
||||
The balance shifts. The neural engine still translates and generates, but the symbolic engine checks, constrains, and corrects. The system is becoming what Gemini called "the strict guard" - a mathematically rigorous layer intercepting probabilistic output.
|
||||
|
||||
**v1.0.0: SOTA Parity - The Probabilistic Ceiling**
|
||||
|
||||
Achieving feature parity with commercial agents requires the full v0.x series complete. At this point, Passepartout is a reliable autonomous agent - it can handle multi-step engineering tasks, maintain context across sessions, recover from errors, pass benchmarks. It is safer than alternatives because the Bouncer is mature and the memory architecture is sound.
|
||||
|
||||
But it is still fundamentally probabilistic at its core. The symbolic engine verifies and constrains, but the generative engine is still the primary reasoning source.
|
||||
|
||||
**v2.0.0: The Agent Becomes the Interface**
|
||||
|
||||
This version is not about the symbolic engine - it is about tools. The agent stops running inside Emacs and starts replacing it. Lish (Lisp shell) emerges: a shell that speaks plists, not POSIX. Org-mode buffers become the file system. Org-babel becomes the REPL. The agent is no longer a passenger in Emacs - it is the operating system.
|
||||
|
||||
The key insight is that the agent's interface and the agent's brain become the same thing. In earlier versions, there is a clear separation: the agent produces output, the TUI displays it. In v2.0.0, the distinction blurs. The agent's thoughts are displayed in Org buffers that are also the interface that the agent manipulates.
|
||||
|
||||
This is the Emacs cannibalization phase. Not hostile replacement but evolution - Emacs was always a Lisp machine, and v2.0.0 completes the metamorphosis.
|
||||
|
||||
**v3.0.0: The Symbolic Breakthrough**
|
||||
|
||||
This is the architectural leap. The system transitions from "probabilistic engine with symbolic verification" to "symbolic engine with probabilistic input and output."
|
||||
|
||||
The 10-80-10 architecture becomes fully realized: ten percent neural for input translation, eighty percent symbolic for reasoning against a knowledge graph, ten percent neural for output formatting. The symbolic engine maintains facts, relationships, rules, and formal proofs. When the neural engine generates something, the symbolic engine verifies it - not by checking against a blocklist, but by running the proposal through a Prolog/Datalog reasoner that understands the domain constraints.
|
||||
|
||||
The deterministic planner takes the wheel. The LLM is no longer consulted for planning decisions - it translates human language to structured queries and structured results back to human language. The planning itself is pure Lisp: task graphs generated by a symbolic reasoner that has access to the full knowledge graph.
|
||||
|
||||
Self-correcting gates replace the learned Bouncer rules. The system learns not just from approved exceptions but from the full history of outcomes - did the plan succeed? Where did it fail? The symbolic engine updates its own rules based on the results.
|
||||
|
||||
The implications are significant. Hallucination becomes structurally impossible because the symbolic engine will not accept a fact that contradicts its knowledge graph. Safety becomes provable because the formal verification layer can prove properties about the system's behavior. Self-improvement becomes stable because the agent modifies skills that are then verified before execution.
|
||||
|
||||
**v4.0.0 and Beyond: Hardware as the Final Constraint**
|
||||
|
||||
The Lisp machine becomes physical. RISC-V with tagged architecture, hardware-enforced type checking, FPGA prototype for the symbolic core. The agent runs not in emulation but on silicon purpose-built for the architecture.
|
||||
|
||||
This is the long horizon. The symbolic engine runs on logic ASICs optimized for symbolic computation. The neural engine runs on GPU or purpose-built matrix math hardware. Lisp orchestrates both, enforcing at the hardware level what it enforced at the software level in earlier versions.
|
||||
|
||||
**The Trajectory as Design Principle**
|
||||
|
||||
Understanding Passepartout as a function in time is not nostalgia. It is architectural guidance. Every decision in v0.x should be made with awareness of where the system is going. Code written today becomes the substrate for v3.0. Skills designed today become the vocabulary the symbolic engine speaks tomorrow.
|
||||
|
||||
The probabilistic beginning is not a weakness to overcome. It is the bootstrap. The system learns the domain through probabilistic inference, and that learned knowledge becomes the seed for the symbolic engine. By the time the symbolic engine takes over, it has a rich knowledge graph to reason about, grown from thousands of probabilistic interactions.
|
||||
|
||||
This is how you build a reasoning machine: start with a learner, make it learn to verify, let verification become the core, remove the learner once it has learned enough.
|
||||
|
||||
* The REPL as Cognitive Substrate
|
||||
:PROPERTIES:
|
||||
:ID: design-repl-cognition
|
||||
:END:
|
||||
|
||||
A REPL - Read, Eval, Print, Loop - is an interactive programming environment that reads an expression, evaluates it, prints the result, and loops back to read the next expression. It is the opposite of batch processing: where batch compiles and runs a program in one shot, a REPL works one expression at a time, with each evaluation building on all previous ones. The programmer defines a function, calls it, inspects the result, modifies it, and calls it again. The state accumulates. The session is the program.
|
||||
|
||||
In Lisp, the REPL is not a debugging tool bolted onto the language - it is the natural mode of interaction. The running image is the environment. When you evaluate =(+ 2 2)=, the result =4= is printed, and you remain in the same image where =+= is defined, where previous definitions persist, where the next expression can reference anything that came before. There is no separation between development and execution. The REPL is not a simulation of the program - it is the program running.
|
||||
|
||||
Passepartout uses the REPL in this spirit, but elevated: it is not merely a tool for writing code, it is the mechanism by which the agent interacts with its own cognition - a loop that mirrors the perceive-reason-act metabolic cycle at the implementation level.
|
||||
|
||||
In the agent's cognitive architecture, the REPL serves three functions that are difficult or impossible to achieve through batch processing or stateless API calls.
|
||||
|
||||
First, the REPL enables verification before commitment. When the agent generates code, it does not write and forget - it evaluates in a running image, observes the result, iterates if incorrect. The feedback loop is tight: the time between writing and seeing the error is measured in milliseconds, not in the round-trip to a language server or a batch compiler. This is the "verification over hallucination" principle from the RLM paper made concrete: the agent tests what it writes before claiming it works.
|
||||
|
||||
Second, the REPL enables stateful exploration. The agent can define a variable, inspect it, modify it, redefine it. The exploration accumulates state across interactions. This is not a debugging session - it is the agent thinking with its hands, working through a problem by trying variations and observing outcomes, keeping the successful ones and discarding the failures.
|
||||
|
||||
Third, the REPL is a shared substrate. When the agent evaluates code, that code runs in the same image as the agent's own cognition. There is no process boundary between the agent and its tools. The REPL is not a subprocess the agent controls - it is a direct interface to the agent's own nervous system.
|
||||
|
||||
This is why the REPL becomes more important as the system matures. In early versions, it is a development tool. In v0.6.0 and beyond, it becomes a cognitive tool: the agent explores hypotheses by evaluating them, verifies the output of sub-agents by inspecting live state, and tests modifications before committing them to the knowledge graph.
|
||||
|
||||
* The Evaluation Harness
|
||||
:PROPERTIES:
|
||||
:ID: design-evaluation-harness
|
||||
:END:
|
||||
|
||||
SOTA parity is meaningless without measurement. A system that claims to match commercial agents must demonstrate it through reproducible benchmarks, not through feature checklists. The evaluation harness is the apparatus by which Passepartout proves its capabilities.
|
||||
|
||||
The industry standard for coding agents is SWE-bench: a corpus of GitHub issues paired with pull requests. The agent is given an issue, must understand the codebase, write a fix, and submit. Success is measured by whether the submitted PR passes the existing test suite. This tests the full chain: understanding, planning, code generation, verification, and multi-step reasoning.
|
||||
|
||||
Passepartout implements a native Lisp harness for this. A background thread clones repositories, feeds issues into the cognitive loop, tracks the resolution trajectory as an Org-mode headline tree, and scores success by test outcomes. The trajectory is persisted: when a resolution fails, the system can inspect where in the chain the reasoning broke down. The headline tree records the agent's thoughts at each step, making the failure auditable and the debugging human-assisted.
|
||||
|
||||
Beyond SWE-bench, the harness includes chaos testing. The system is subjected to resource starvation, concurrent load, and adversarial input. The deterministic engine must maintain safety invariants under pressure. The symbolic verifier must not deadlock or livelock. The probabilistic engine must degrade gracefully - if tokens are limited, it must still produce valid proposals that the deterministic engine can evaluate. Failure under chaos is a design flaw, not a benchmark anomaly.
|
||||
|
||||
The harness also supports regression testing on the skill set. Every skill is tested against a suite of known inputs and expected outputs. When a modification is proposed to any skill - whether through manual editing or the agent's own self-modification - the test suite runs first. A skill that fails its tests is rejected before it can propagate to the running image. This is not a convenience - it is the mechanism by which self-modification remains safe. The agent can propose changes, but the harness verifies them before the changes take effect.
|
||||
|
||||
* Observability and the Thought Trace
|
||||
:PROPERTIES:
|
||||
:ID: design-observability
|
||||
:END:
|
||||
|
||||
When a human asks why the system made a decision, the answer must be findable. In most AI systems, the reasoning is ephemeral - it exists in the model's activations and disappears when the session ends. In Passepartout, every significant cognitive event is written to an Org buffer as it happens.
|
||||
|
||||
The thought trace is the agent's journal, written in parallel with its reasoning. When the probabilistic engine generates a proposal, the trace records the input, the prompt, and the raw output. When the deterministic engine evaluates it, the trace records which rules were checked, which passed, which failed, and why. When an action is executed, the trace records the timestamp, the user who approved it (if human-in-the-loop), and the outcome.
|
||||
|
||||
This is not logging in the traditional sense. Logs are forensically useful but are written in a machine format optimized for storage, not for human reading. The thought trace is written in Org-mode: headlines for major events, property drawers for structured data, tags for categorization. The human can open the trace in Emacs and navigate it like any other Org file. They can search for a specific decision, filter by time range, find all actions blocked by a specific rule, or see the complete trajectory of a multi-step task.
|
||||
|
||||
The trace becomes the foundation for the Bouncer's learning. Every blocked action is in the trace. Every approved exception is in the trace. The human-in-the-loop decisions are in the trace. The system does not need to reconstruct what happened - it reads what happened from the trace it wrote.
|
||||
|
||||
Without observability, the system is a black box that happens to produce correct outputs sometimes. With observability, the system is auditable. The human can see why a decision was made, identify where the reasoning failed, and course-correct the system or its own behavior accordingly.
|
||||
|
||||
* The MCP Strategy
|
||||
:PROPERTIES:
|
||||
:ID: design-mcp-strategy
|
||||
:END:
|
||||
|
||||
The Model Context Protocol (MCP) is a standard for connecting AI systems to external tools and data sources. It defines how a client requests tools from a server, how the server exposes its capabilities, and how the client invokes them. The ecosystem is growing: MCP servers exist for GitHub, Slack, Postgres, filesystem access, and much more.
|
||||
|
||||
Passepartout connects to this ecosystem, but not by becoming a Node.js runtime. The architecture is: external MCP servers communicate via stdio or SSE to a Lisp-native MCP client that runs in the same image as the agent. The client is pure Common Lisp - it parses the JSON-RPC messages, invokes the tools, and presents results to the agent as Lisp data structures. There is no serialization overhead between the agent and the MCP layer, no process boundary, no impedance mismatch.
|
||||
|
||||
When the agent calls a tool via MCP, it receives a plist with the tool name, arguments, and result. The result is immediately usable by the agent's symbolic engine. When the agent generates a file, it can be written to the filesystem through an MCP filesystem server. When the agent needs to send a message, it can use an MCP Slack server. The agent does not need to know that these are MCP interactions - it sees only the plists that flow through its cognitive architecture.
|
||||
|
||||
The alternative is to build MCP wrappers in Python or TypeScript and bridge to Lisp via subprocess. This is what OpenClaw does: a Node.js runtime that manages MCP servers, with a bridge to the Lisp process. The bridge introduces latency, serialization costs, and a maintenance burden. The Node.js process must be kept running. The bridge must be maintained across Lisp and JavaScript runtimes. The cognitive architecture must handle errors that cross the process boundary.
|
||||
|
||||
Passepartout's native client is smaller, faster, and more maintainable. The MCP client is a skill, not a core component. It can be reloaded, replaced, or removed without restarting the agent. The agent can add new MCP tool integrations by loading new skills, not by deploying new infrastructure.
|
||||
|
||||
* Local-First Architecture
|
||||
:PROPERTIES:
|
||||
:ID: design-local-first
|
||||
:END:
|
||||
|
||||
Passepartout is designed to run on the user's machine, on their hardware, with their data, without requiring an internet connection. This is not a deployment option - it is an architectural commitment. The system must be able to reason, plan, and act using only the resources available locally.
|
||||
|
||||
The motivation is not merely philosophical. Cloud-based AI agents are economically incentivized to collect data, to train on user interactions, and to build lock-in through proprietary formats and network effects. When the agent runs locally, the user owns the hardware, owns the data, and can terminate the process without asking permission. There is no vendor that can change terms, no service that can go offline, no model that can be updated without consent.
|
||||
|
||||
Technically, local-first means several things. The LLM must be able to run on local hardware. Passepartout supports Ollama as a provider, which runs quantized models on CPU and GPU without requiring an external API. The vector database must be local. Passepartout uses its own org-object store, which is a folder of Org files that the agent already owns. There is no ChromaDB or Qdrant to install, no cloud vector service to authenticate with.
|
||||
|
||||
The symbolic engine does not require a network connection. The Prolog/Datalog reasoner that in v3.0.0 verifies neural proposals runs entirely in the Lisp image. The Bouncer's rule synthesis does not call an external service. The agent can operate in a disconnected environment indefinitely, resuming full capability when connectivity is restored.
|
||||
|
||||
This does not mean Passepartout refuses to use cloud services when available and appropriate. It means cloud services are optional enhancements, not architectural requirements. The core is local. The user can choose to add cloud LLM providers for more capable inference, but the system functions without them.
|
||||
|
||||
* Zero-Dependency Deployment
|
||||
:PROPERTIES:
|
||||
:ID: design-zero-dependency
|
||||
:END:
|
||||
|
||||
The simplest deployment is one that requires no installation steps. The user downloads one file, runs it, and the system works. Passepartout approximates this through SBCL's ability to produce standalone executables via save-lisp-and-die. The executable contains the Lisp runtime, the compiled system, and Quicklisp libraries - everything bundled into one binary.
|
||||
|
||||
The practical reality is more nuanced. Building a truly standalone executable requires resolving all library dependencies at build time and embedding them in the binary. SBCL supports this, but the resulting binary is large (tens of megabytes), and updating any component requires a full rebuild. The current deployment model uses a Docker container that maps the user's memex directory as a volume. The container starts, loads the system, and is ready. No compilation on the user's machine, no dependency installation, no platform-specific quirks.
|
||||
|
||||
The long-term goal is a single =passepartout= binary that the user runs. It starts a local web server on a Unix domain socket. The TUI connects through the socket. The user's Org files are in =~/memex/=. The binary is the only thing that needs to be installed.
|
||||
|
||||
This stands in stark contrast to most AI agent systems, which require managing Python environments, npm packages, API keys, environment variables, and configuration files. OpenAI's agents SDK requires pip install, a Python environment, and external API access. OpenClaw requires Node.js, npm, and a plugin ecosystem that must be individually installed. LangChain requires a Python environment with dozens of dependencies that must be kept compatible.
|
||||
|
||||
Passepartout's dependency model is SBCL plus Quicklisp. Quicklisp loads libraries on demand from the internet, but caches them locally. A system with internet access can fetch any library it needs. A system without internet access uses only the libraries it has already loaded - and those are preserved in the cache. The agent does not require internet access to function after initial setup.
|
||||
|
||||
* Token Economics and Performance Advantage
|
||||
:PROPERTIES:
|
||||
:ID: design-token-economics
|
||||
:END:
|
||||
|
||||
This section analyzes how Passepartout's architectural decisions translate into token usage, latency, and cost versus competing agent designs (OpenClaw, Hermes, Claude Code).
|
||||
|
||||
** The Core Insight: LLM as Expensive Resource, Not Default Engine
|
||||
|
||||
Passepartout treats the LLM as a resource to be minimized. Every operation is designed to reduce LLM dependency. Competitors treat the LLM as the core engine through which all operations flow. This is not a difference of degree but of architecture.
|
||||
|
||||
The three structural multipliers are:
|
||||
|
||||
1. *Sparse tree retrieval* — loading relevant subtrees (200-800 tokens per file) rather than full files (1,500-5,000 tokens) = ~5-10x reduction per file access
|
||||
2. *Deterministic safety* — 9-vector dispatcher gate runs in pure Lisp (0 LLM tokens per verification) versus prompt-based guardrails (200-500 tokens per action) = infinite multiplier
|
||||
3. *REPL verification* — catches errors in-image (milliseconds, 0 LLM tokens) versus LLM correction round-trips (500-2,000 tokens per retry)
|
||||
|
||||
These compound. A coding session touching 20 files, performing 10 actions, and triggering 3 errors saves ~50,000-100,000 tokens compared to the same session with Claude Code.
|
||||
|
||||
** Per-Task Type Analysis
|
||||
|
||||
*** Coding (debugging, refactoring, PR review)
|
||||
|
||||
| Operation | Passepartout | Claude Code | Hermes (3-agent) | Savings vs Claude |
|
||||
|-----------|-------------|-------------|-------------------|--------------------|
|
||||
| File access (30 files) | 30 × 400 tok = 12,000 | 30 × 3,000 tok = 90,000 | 30 × 3,000 tok × 3 = 270,000 | 78,000 tok |
|
||||
| Reasoning rounds (20) | 20 × 3,000 tok = 60,000 | 20 × 4,000 tok = 80,000 | 20 × 3,000 tok × 3 = 180,000 | 20,000 tok |
|
||||
| Error correction (5 caught by REPL) | 0 (REPL) | 5 × 1,000 tok = 5,000 | 5 × 1,000 tok × 3 = 15,000 | 5,000 tok |
|
||||
| Safety verification | 0 (deterministic) | 500 tok/round × 20 = 10,000 | 200 tok/round × agents | 10,000 tok |
|
||||
| Agent coordination | 0 | 0 | 3,000-5,000 tok/task | 0 |
|
||||
| *Total* | *~72,000 tok* | *~185,000 tok* | *~475,000 tok* | *~113,000 tok (2.6x)* |
|
||||
|
||||
Over a month of daily coding (20 sessions): ~2.3 million tokens saved. At typical API pricing ($2-15/M tokens), this saves $5-35/month.
|
||||
|
||||
*** Knowledge Management (Zettelkasten, research, note-taking)
|
||||
|
||||
Passepartout's strongest domain. The Org-mode native format and sparse tree retrieval create a 10-40x advantage because knowledge bases are the worst case for "load everything" architectures.
|
||||
|
||||
| Operation | Passepartout | Competitor | Savings |
|
||||
|-----------|-------------|------------|---------|
|
||||
| Context assembly (500-node KB) | Peripheral outline + ~5 foveal nodes = 2,000-4,000 tok | Full serialization = 80,000-150,000 tok | 40-75x |
|
||||
| Semantic search (10 queries) | Vector lookup in-image = 0 LLM tok | LLM-assisted search = 5,000 tok | 5,000 tok |
|
||||
| Note creation (10 notes) | Deterministic Org writes = 0 LLM tok | 10 × 800 tok = 8,000 | 8,000 tok |
|
||||
| *Total per session* | *~7,000 tok* | *~95,000-165,000 tok* | *~13-24x* |
|
||||
|
||||
*** Day-to-Day Life Management (calendar, tasks, reminders)
|
||||
|
||||
| Operation | Passepartout | Competitor | Savings |
|
||||
|-----------|-------------|------------|---------|
|
||||
| Background maintenance | Deterministic heartbeat-driven = 0 LLM tok | Scheduled LLM calls or skipped | Variable |
|
||||
| User interactions (30/day) | 30 × 2,000 tok = 60,000 | 30 × 4,000 tok = 120,000 | 60,000 tok |
|
||||
| Context queries by TODO/tag | Hash table scan = 0 LLM tok | LLM-based search = 2,500 tok | 2,500 tok |
|
||||
| *Total per day* | *~60,000 tok* | *~122,500 tok* | *~2x* |
|
||||
|
||||
The defining advantage: background maintenance (compaction, archiving, link repair) costs zero LLM tokens. Competing systems either skip this or pay LLM costs for it.
|
||||
|
||||
*** Chatting (casual conversation)
|
||||
|
||||
Chatting is inherently LLM-bound. Passepartout's edge is privacy filtering before content reaches the LLM and slightly smaller context footprint. Token savings are marginal (~1.3x).
|
||||
|
||||
** The Dispatcher Learning Curve: Cost Decreases Over Time
|
||||
|
||||
A unique architectural property: Passepartout's cost curve descends while competitors' ascends.
|
||||
|
||||
Passepartout: As the dispatcher accumulates deterministic rules from Human-in-the-Loop decisions, fewer actions require LLM proposals. A file write that initially triggered a full LLM proposal → dispatcher review → HITL approval → rule extraction loop eventually becomes a deterministic rule check. Each hardened rule permanently reduces future token costs.
|
||||
|
||||
Competitors: As context histories grow, safety instructions accumulate, and guardrails become more elaborate, each interaction costs more than the last. The only way to reduce cost is to cap context — sacrificing capability.
|
||||
|
||||
After 12 months of learning, Passepartout's core reasoning costs could drop to 40-60% of baseline, while competitors' costs rise to 125-140% of baseline.
|
||||
|
||||
The crossover point where Passepartout becomes structurally cheaper is estimated at 3-6 months depending on usage volume and task diversity.
|
||||
|
||||
** Local LLM Viability
|
||||
|
||||
Reduced context requirements change which model sizes deliver acceptable performance:
|
||||
|
||||
| Model | Passepartout Viability | Competitor Viability |
|
||||
|-------|----------------------|---------------------|
|
||||
| Phi-3-mini 3.8B (4K ctx) | Viable for structured tasks | Context starvation |
|
||||
| Llama 3.1 8B (8K ctx) | Comfortable daily driver | Marginal |
|
||||
| Qwen 2.5 7B (4K ctx) | Viable for most tasks | Not viable |
|
||||
| Mistral 7B (8K ctx) | Comfortable | Marginal |
|
||||
| Llama 3.1 70B (128K ctx) | Overkill (but works) | Comfortable |
|
||||
|
||||
KV cache memory scales with context length:
|
||||
|
||||
| Context Window | KV Cache (Llama 3.1 8B, FP16) |
|
||||
|---------------|-------------------------------|
|
||||
| 4K tokens | ~67 MB |
|
||||
| 32K tokens | ~540 MB |
|
||||
| 128K tokens | ~2.1 GB |
|
||||
|
||||
Passepartout at 4K effective context: ~67 MB KV cache. Competitor at 128K: ~2.1 GB. A 7-8B model on an RTX 3060 Ti (8 GB VRAM) or MacBook (16 GB unified memory) is a practical daily driver with Passepartout. Competitors at full context require 16-32 GB VRAM or cloud APIs.
|
||||
|
||||
** Open Questions and Risks
|
||||
|
||||
1. *Retrieval accuracy is the bottleneck.* If sparse tree retrieval loads the wrong subtree (low-similarity but causally relevant), the LLM makes unfixable errors. The architecture assumes embedding quality is "good enough" — this is untested at scale.
|
||||
|
||||
2. *System prompt overhead can consume savings.* Every =think= cycle iterates all registered skills and calls every =system-prompt-augment= function. With 20+ skills, a trivial interaction could carry 3,000-8,000 tokens of overhead before user input is even processed. This overhead is flat per-call, so it disproportionately affects short interactions.
|
||||
|
||||
3. *Model size vs context quality.* A 3.8B model with perfect context cannot match a 70B model on complex multi-file refactors regardless of context quality. Model size independently determines reasoning depth. The minimum viable model is likely 7-13B parameters for engineering work.
|
||||
|
||||
4. *The 3-retry dispatcher loop.* When the dispatcher rejects a proposal, the rejection trace feeds back to the LLM for self-correction (up to 3 retries). If the dispatcher rejects 30% of proposals, the effective token multiplier is 1.39x per action. At 50% rejection (plausible during early use), it is 1.75x. This penalty decreases as the dispatcher accumulates rules.
|
||||
|
||||
5. *Competitor evolution.* Sparse retrieval is not patentable. Claude Code, Copilot, and others will implement similar mechanisms. The architectural advantage is real but finite in duration. The deterministic safety gate is the harder-to-replicate differentiator.
|
||||
|
||||
** Comparison Summary
|
||||
|
||||
| Metric | Passepartout | Claude Code | Hermes | OpenClaw |
|
||||
|--------|-------------|-------------|--------|----------|
|
||||
| Active context (tokens) | 2,000-4,000 | 10,000-50,000+ | 5,000-15,000/agent | 10,000-40,000 |
|
||||
| File access cost (per file) | 200-800 tok | 1,500-5,000 tok | 1,500-5,000 tok × agents | 1,500-5,000 tok |
|
||||
| Safety verification cost | 0 (deterministic) | 200-500 tok/action | 200-500 tok/action × agents | 100-300 tok/action |
|
||||
| Agent coordination cost | 0 | 0 | 1,000-3,000 tok/task | 500-2,000 tok/task |
|
||||
| Error recovery cost | 0 (REPL) | 500-2,000 tok/retry | 500-2,000 tok/retry × agents | 500-2,000 tok/retry |
|
||||
| Long-term cost trend | Decreasing | Increasing | Increasing | Flat/Increasing |
|
||||
| Min viable local model | 3-4B params, 4K ctx | 30-70B params, 32K+ ctx | 30-70B params, 32K+ ctx | 7-13B params, 8K+ ctx |
|
||||
| Min VRAM for local | 4-6 GB | 16-32 GB | 24-48 GB | 8-16 GB |
|
||||
|
||||
*Conclusion:* Passepartout's architecture is designed to produce 2-3x token savings for coding, 13-24x for knowledge management, and 2x for life management at v1.0.0 maturity. The three structural advantages — sparse trees, deterministic safety, and REPL verification — compound. The critical risk is implementation gap: achieving the retrieval precision, dispatcher learning, and REPL integration depth required to realize the design.
|
||||
538
docs/ROADMAP.org
Normal file
538
docs/ROADMAP.org
Normal file
@@ -0,0 +1,538 @@
|
||||
#+TITLE: Passepartout Evolutionary Roadmap
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :docs:roadmap:
|
||||
|
||||
* The Evolutionary Roadmap
|
||||
|
||||
The roadmap is designed working backwards from SOTA parity (v1.0.0), guiding each version toward a fully autonomous, self-editing agent. Each version builds on the previous, with features designed to be implemented in pure Common Lisp + Org-mode.
|
||||
|
||||
The TODO states in each version's Tasks section are the authoritative task tracker. The feature tables describe what each version delivers.
|
||||
|
||||
** Non-Negotiable Identity
|
||||
- Pure Common Lisp + Org-mode. No JSON. No YAML. No external databases.
|
||||
- Single-address-space memory (Lisp hash tables in RAM — the agent IS the memory).
|
||||
- "Thin harness, fat skills" — complexity lives at the edges, not the kernel.
|
||||
- One agent composed of many skills. Concurrency via bordeaux-threads (shared memory).
|
||||
- Plists everywhere — homoiconic communication between all components.
|
||||
|
||||
** Version Roadmap
|
||||
|
||||
*** v0.1.0: The Autonomous Foundation — RELEASED 2026-04-20
|
||||
|
||||
The secure, auditable Lisp kernel. All core infrastructure in place.
|
||||
|
||||
**** DONE Perceive-Reason-Act pipeline
|
||||
:PROPERTIES:
|
||||
:ID: id-06f10b9a-4054-4dea-a927-b0935fbdcd2f
|
||||
:CREATED: [2026-03-22 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-20 Mon]
|
||||
:END:
|
||||
|
||||
**** DONE Skills engine with jailed loading
|
||||
:PROPERTIES:
|
||||
:ID: id-dc83944f-3923-4142-b324-c317dacd6b0b
|
||||
:CREATED: [2026-03-22 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-20 Mon]
|
||||
:END:
|
||||
|
||||
**** DONE Policy skill (6 invariants)
|
||||
:PROPERTIES:
|
||||
:ID: id-929c84b7-d6ae-42b9-a8b5-d9df962db826
|
||||
:CREATED: [2026-03-22 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-20 Mon]
|
||||
:END:
|
||||
|
||||
**** DONE Memory (memory-object + Merkle hashing)
|
||||
:PROPERTIES:
|
||||
:ID: id-3a96b384-cacf-4da0-8faa-1647739feba9
|
||||
:CREATED: [2026-03-22 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-20 Mon]
|
||||
:END:
|
||||
|
||||
**** DONE Scribe + Gardener background workers
|
||||
:PROPERTIES:
|
||||
:ID: id-3f618a38-ec23-4034-ba3c-ef272e212e2b
|
||||
:CREATED: [2026-03-22 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-20 Mon]
|
||||
:END:
|
||||
|
||||
**** DONE LLM gateway (OpenRouter, Ollama)
|
||||
:PROPERTIES:
|
||||
:ID: id-f5d870e2-cbd2-4c00-a8d4-174ab4118afc
|
||||
:CREATED: [2026-04-11 Sat]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-20 Mon]
|
||||
:END:
|
||||
|
||||
**** DONE Shell actuator, Emacs bridge, credentials vault
|
||||
:PROPERTIES:
|
||||
:ID: id-7ca3167f-8353-4bb7-8b97-c039017716b0
|
||||
:CREATED: [2026-04-11 Sat]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-20 Mon]
|
||||
:END:
|
||||
|
||||
**** DONE FiveAM test suite
|
||||
:PROPERTIES:
|
||||
:ID: id-925d4180-764b-4219-8bdc-8e1849572da1
|
||||
:CREATED: [2026-04-11 Sat]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-20 Mon]
|
||||
:END:
|
||||
|
||||
*** v0.2.0: Interactive Refinement — RELEASED 2026-04-29
|
||||
|
||||
The "Brain" meets the "Machine." Standardization and professionalization of the user interface and environment.
|
||||
|
||||
**** DONE Professional TUI (Croatoan-based, styled, scrollable)
|
||||
:PROPERTIES:
|
||||
:ID: id-57cef382-fe14-42e6-aade-03e05e3e920b
|
||||
:CREATED: [2026-04-28 Tue]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-29 Wed]
|
||||
:END:
|
||||
|
||||
**** DONE Self-editing (error detection, surgical fix, hot-reload)
|
||||
:PROPERTIES:
|
||||
:ID: id-459b8275-9979-4d0f-8d61-a9af883930d4
|
||||
:CREATED: [2026-04-23 Wed]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-29 Wed]
|
||||
:END:
|
||||
|
||||
**** DONE Enhanced utilities (structural Lisp/Org manipulation + REPL)
|
||||
:PROPERTIES:
|
||||
:ID: id-23f37c0d-4e77-4dc3-ab43-52a5987eb426
|
||||
:CREATED: [2026-04-23 Wed]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-29 Wed]
|
||||
:END:
|
||||
|
||||
**** DONE Onboarding wizard (modular Lisp setup for LLM providers)
|
||||
:PROPERTIES:
|
||||
:ID: id-bd497de7-3533-4056-b89f-2c992d2ea28b
|
||||
:CREATED: [2026-04-28 Tue]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-29 Wed]
|
||||
:END:
|
||||
|
||||
**** DONE Memory rollback (snapshot and restore)
|
||||
:PROPERTIES:
|
||||
:ID: id-fd2fb6e3-03e7-4e22-b9e9-a7eecfd06718
|
||||
:CREATED: [2026-04-12 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-04-29 Wed]
|
||||
:END:
|
||||
|
||||
**** DONE Secret Exposure Gate, Shell Safety, Lisp Validation
|
||||
:PROPERTIES:
|
||||
:ID: id-aa53c128-195b-42d4-9838-2def59faf7cf
|
||||
:CREATED: [2026-05-02 Sat]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-02 Sat]
|
||||
:END:
|
||||
|
||||
**** DONE Multi-distro deployment (Debian+Fedora, systemd, Docker)
|
||||
:PROPERTIES:
|
||||
:ID: id-783df999-f7fe-45c8-896d-2fd07c604d64
|
||||
:CREATED: [2026-05-02 Sat]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-02 Sat]
|
||||
:END:
|
||||
|
||||
**** DONE Project rename to Passepartout (files, packages, env vars)
|
||||
:PROPERTIES:
|
||||
:ID: id-91724874-aa0d-4804-9220-8bc5551f1366
|
||||
:CREATED: [2026-05-02 Sat]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-02 Sat]
|
||||
:END:
|
||||
|
||||
**** DONE 31 org files with full literate prose
|
||||
:PROPERTIES:
|
||||
:ID: id-597b2a92-aac6-481a-b2c4-4f9842ced97c
|
||||
:CREATED: [2026-05-02 Sat]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-02 Sat]
|
||||
:END:
|
||||
|
||||
*** v0.3.0: Event Orchestration + HITL
|
||||
|
||||
Unified control plane and Human-in-the-Loop state management.
|
||||
|
||||
** Tasks
|
||||
|
||||
*** Remediation: Backfill v0.1.0/v0.2.0 Gaps
|
||||
|
||||
These features were marked DONE in prior versions but are stubs, no-ops, or
|
||||
missing. They must be completed before v0.3.0 feature work proceeds.
|
||||
|
||||
**** DONE P0: Add vault-get-secret / vault-set-secret wrappers :backfill:
|
||||
CLOSED: [2026-05-03 Sun 10:42]
|
||||
:PROPERTIES:
|
||||
:ID: id-vault-secret-wrappers
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-03 Sun 10:42]
|
||||
:END:
|
||||
=vault-get-secret= and =vault-set-secret= are exported from =core-defpackage=
|
||||
and called from =gateway-manager.org= (lines 36, 86, 180) but never defined.
|
||||
=gateway-link= crashes at runtime. Add one-line wrappers in =security-vault.org=
|
||||
that delegate to the existing =vault-get=/=vault-set= with ~:type :secret~.
|
||||
|
||||
**** DONE P0: system-archivist — Scribe + Gardener :backfill:
|
||||
CLOSED: [2026-05-03 Sun 10:42]
|
||||
:PROPERTIES:
|
||||
:ID: id-archivist-distillation
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-03 Sun 10:42]
|
||||
:END:
|
||||
Scribe: distill daily Org logs into atomic Zettelkasten notes with backlinks.
|
||||
Gardener: scan for broken =[[file:]]= links and orphaned =memory-object= entries.
|
||||
Wire both as cron jobs via =system-event-orchestrator=.
|
||||
Depends on: orchestrator bootstrap (P1 item below).
|
||||
|
||||
**** DONE P0: system-self-improve — surgical edit + error fix :backfill:
|
||||
CLOSED: [2026-05-03 Sun 10:42]
|
||||
:PROPERTIES:
|
||||
:ID: id-self-improve-real
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-03 Sun 10:42]
|
||||
:END:
|
||||
= self-improve-edit=: =org-read-file= → text replace → =snapshot-memory= →
|
||||
=org-write-file= → =literate-block-balance-check= → tangle → reload.
|
||||
=self-improve-fix=: parse error log → =lisp-structural-check= →
|
||||
=lisp-extract= → surgical repair → =repl-eval= verify.
|
||||
Remove the dead first =defskill= registration (trigger nil, overwritten by second).
|
||||
Depends on: =programming-org=, =programming-literate= (P0 items below).
|
||||
|
||||
**** DONE P0: programming-org — fix org-modify + org-ast-render :backfill:
|
||||
CLOSED: [2026-05-03 Sun 10:42]
|
||||
:PROPERTIES:
|
||||
:ID: id-org-modify-render
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-03 Sun 10:42]
|
||||
:END:
|
||||
=org-modify(filepath, id, changes)= ignores ~changes~ and only logs. Should locate
|
||||
node by ID in file and apply changes to its content.
|
||||
=org-ast-render(ast)= returns a hardcoded placeholder. Should convert plist AST
|
||||
back to Org text.
|
||||
|
||||
**** DONE P0: programming-literate — fix both stubs :backfill:
|
||||
CLOSED: [2026-05-03 Sun 10:42]
|
||||
:PROPERTIES:
|
||||
:ID: id-literate-real
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-03 Sun 10:42]
|
||||
:END:
|
||||
=literate-block-balance-check=: verify all =#+begin_src lisp= blocks in an Org file
|
||||
have balanced parentheses. Returns T if all balanced, error message otherwise.
|
||||
=literate-tangle-sync-check=: verify =.lisp= file matches tangled output of =.org= file.
|
||||
|
||||
**** DONE P1: system-event-orchestrator — bootstrap implementation :backfill:
|
||||
CLOSED: [2026-05-03 Sun 10:42]
|
||||
:PROPERTIES:
|
||||
:ID: id-orchestrator-bootstrap
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-03 Sun 10:42]
|
||||
:END:
|
||||
=orchestrator-bootstrap= currently only logs. Should scan Org files for =#+HOOK:=
|
||||
and =#+CRON:= properties and register them via the existing registries.
|
||||
Prerequisite for archivist cron jobs.
|
||||
|
||||
**** DONE P1: system-memory — memory introspection :backfill:
|
||||
CLOSED: [2026-05-03 Sun 10:42]
|
||||
:PROPERTIES:
|
||||
:ID: id-memory-inspect
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-03 Sun 10:42]
|
||||
:END:
|
||||
=memory-inspect= only logs. Should return structured statistics: object count
|
||||
by type, TODO state distribution, orphan count, snapshot list. Trigger on
|
||||
=:INTROSPECTION= sensor type.
|
||||
|
||||
**** DONE P1: Path relic — skills/ → lisp/ in skill-initialize-all :backfill:
|
||||
CLOSED: [2026-05-03 Sun 10:42]
|
||||
:PROPERTIES:
|
||||
:ID: id-path-relic
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-03 Sun 10:42]
|
||||
:END:
|
||||
=skill-initialize-all= and =context-skill-source= resolve against =skills/=
|
||||
under =$PASSEPARTOUT_DATA_DIR=. Core and skills were merged into =lisp/=.
|
||||
Update both functions to point at =lisp/=.
|
||||
|
||||
**** TODO P2: core-context — semantic retrieval (embeddings) :backfill:
|
||||
:PROPERTIES:
|
||||
:ID: id-embeddings
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
:END:
|
||||
=org-object-vector= is never populated; all similarities are 0.0. Generate
|
||||
embeddings via Ollama =nomic-embed-text= at ingest time. Store in
|
||||
=memory-object.vector=. Fallback: TF-IDF bag-of-words.
|
||||
|
||||
**** TODO P2: core-context — subtree-based skill source loading :backfill:
|
||||
:PROPERTIES:
|
||||
:ID: id-skill-subtree
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
:END:
|
||||
=context-skill-source= reads entire Org files. Add =context-skill-subtree=
|
||||
for targeted retrieval of specific function docs or test blocks by heading name.
|
||||
|
||||
**** TODO P3: Variable name drift normalization (out of scope for now) :backfill:
|
||||
:PROPERTIES:
|
||||
:ID: id-name-normalization
|
||||
:CREATED: [2026-05-03 Sun]
|
||||
:END:
|
||||
=*memory*= (context) vs =*memory-store*= (memory). =*skills-registry*= with
|
||||
underscore (reason/context) vs =*skill-registry*= with hyphen (defpackage).
|
||||
Normalization pass across all modules. Touches every file — do after P0-P2
|
||||
are stable. Do not mix with functional changes.
|
||||
|
||||
*** DONE Project Renaming (Bouncer → Dispatcher)
|
||||
:PROPERTIES:
|
||||
:ID: id-9e779580-287b-b3d1-37b9-bcefd750bf9e
|
||||
:CREATED: [2026-05-01 Fri 15:40]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-02 Sat 22:00]
|
||||
:END:
|
||||
The Dispatcher's role has evolved beyond security guard. It is the seed of the deterministic engine — it learns to execute procedures without invoking the neural net.
|
||||
|
||||
*** DONE Event Orchestrator (unified hooks+cron+routing)
|
||||
:PROPERTIES:
|
||||
:ID: id-d35aea3d-2e5f-4a12-a9b0-1c2d3e4f5a6b
|
||||
:CREATED: [2026-05-02 Sat 14:00]
|
||||
:END:
|
||||
:LOGBOOK:
|
||||
- State "DONE" from "TODO" [2026-05-02 Sat 22:36]
|
||||
:END:
|
||||
Unified control plane for hooks, cron, and complexity-based routing.
|
||||
- *hook-registry* + *cron-registry* + tier classifier
|
||||
- Hooks via ~#+HOOK:~ Org-mode properties
|
||||
- Three complexity tiers: ~:REFLEX~ (no LLM), ~:COGNITION~ (light LLM), ~:REASONING~ (full LLM)
|
||||
- Hooked into heartbeat for cron processing
|
||||
- Rule-based tier classifier (overrideable via ~*tier-classifier*~)
|
||||
|
||||
*** TODO Context Manager (project scoping)
|
||||
:PROPERTIES:
|
||||
:ID: id-a10ed34e-9f37-4a15-b499-46672c00d951
|
||||
:CREATED: [2026-05-02 Sat 23:00]
|
||||
:END:
|
||||
Stack-based context with ~push-context~ / ~pop-context~.
|
||||
Path resolution relative to current context.
|
||||
Memory scope: ~:scope~ property on memory-objects (memex/session/project).
|
||||
Implement lazy-loading proxies for large-scale memory traversal.
|
||||
|
||||
*** TODO Model-Tier Routing (cost optimization)
|
||||
Extend ~*model-selector-fn*~ for complexity-based routing.
|
||||
- Heartbeats → smallest model
|
||||
- User input → medium model
|
||||
- Complex reasoning → large model
|
||||
|
||||
*** TODO Memory Scope Segmentation
|
||||
Extend memory-object with ~:scope~ property.
|
||||
- ~:memex~ (permanent knowledge), ~:session~ (ephemeral), ~:project~ (current work)
|
||||
- Scope-aware retrieval in memory layer
|
||||
|
||||
*** TODO Asynchronous Embedding Gateway
|
||||
Provider-agnostic vector generation (Ollama, llama.cpp, OpenAI).
|
||||
Edits mark nodes as ~:vector :pending~; background worker batches and updates Merkle tree.
|
||||
|
||||
*** TODO TUI Experience (Daily Driver Quality)
|
||||
The TUI is a standalone Croatoan app in ~org/gateway-tui.org~.
|
||||
None of these changes require daemon modifications — the protocol between TUI and
|
||||
daemon (port 9105, framed plists) is stable.
|
||||
|
||||
- P0: Chat scrollback (Page Up/Down) — ~2h
|
||||
- P0: Input history (up/down arrows) — ~1h
|
||||
- P1: Status bar (daemon, model, time) — ~3h
|
||||
- P1: Message rendering (timestamps, colors, wrapping) — ~2h
|
||||
- P2: Command palette (/help redesign) — ~4h
|
||||
- P2: Multi-line input (Shift+Enter) — ~3h
|
||||
- P3: Background activity indicator — ~2h
|
||||
- P4: Tab completion for / commands — ~3h
|
||||
- P4: Configurable theme — ~4h
|
||||
|
||||
*** TODO Human-in-the-Loop (HITL)
|
||||
Continuation-based interaction. The agent can suspend its cognitive loop to ask for
|
||||
permission or clarification and resume precisely where it left off. Builds on the
|
||||
dispatcher's existing Flight Plan mechanism.
|
||||
|
||||
*** v0.4.0: Long-Horizon Planning + Git Workflows
|
||||
|
||||
Structured tracking, failure handling, and course correction for multi-step engineering work.
|
||||
|
||||
** Tasks
|
||||
|
||||
*** TODO Long-Horizon Planning (task tree DAG)
|
||||
Decompose complex tasks into Org-mode headline trees.
|
||||
Terminal states: ~:todo~ → ~:next-action~ → ~:in-progress~ → ~:done~ / ~:blocked~ / ~:stuck~.
|
||||
Parent summarises child results.
|
||||
Branch pruning when paths fail.
|
||||
|
||||
*** TODO Git Steward (version control integration)
|
||||
Status, diff, commit, push, branch operations.
|
||||
Policy enforces commit-before-modify gate.
|
||||
Log commits to memory.
|
||||
|
||||
*** TODO TDD Runner Integration
|
||||
Run FiveAM tests on file save.
|
||||
Inject ~:test-failure~ event on red.
|
||||
Hook into self-fix for auto-repair proposals.
|
||||
|
||||
*** TODO Deep Emacs Integration
|
||||
Full org-agenda awareness: navigate, clock time, refile, archive.
|
||||
Uses org-element + org-id.
|
||||
|
||||
*** v0.5.0: Interactive Actuation & Environment Stewardship
|
||||
|
||||
Interactive terminal sessions and autonomous dependency management.
|
||||
|
||||
** Tasks
|
||||
|
||||
*** TODO Interactive PTY Actuator
|
||||
Stream long-running process output to the context window (e.g., ~npm run dev~, REPLs).
|
||||
Async interrupt control (Ctrl+C emulation).
|
||||
|
||||
*** TODO The Environment Steward
|
||||
Autonomously detect missing dependencies ("Command not found").
|
||||
Propose installation command and retry the failed action.
|
||||
|
||||
*** v0.6.0: Concurrency + Creator + GTD
|
||||
|
||||
The agent bootstraps itself and manages parallel workstreams.
|
||||
|
||||
** Tasks
|
||||
|
||||
*** TODO Skill Creator (autonomous skill generation)
|
||||
LLM drafts complete skill org-file from natural language.
|
||||
Mandatory: syntax validation → jail-load → test → register.
|
||||
|
||||
*** TODO Architect Agent (PRD → PROTOCOL)
|
||||
Scan ~:STATUS: FROZEN~ PRDs. Generate Phase B PROTOCOL from Phase A.
|
||||
|
||||
*** TODO GTD Integration (project tracking)
|
||||
Full GTD cycle: capture, clarify, organize, reflect, engage.
|
||||
org-gtd v4.0 DAG (~:TRIGGER:~, ~:BLOCKER:~).
|
||||
|
||||
*** TODO Consensus Loop (multi-model agreement)
|
||||
Run multiple providers for critical decisions.
|
||||
Compare results, detect disagreements.
|
||||
Confidence scoring.
|
||||
|
||||
*** TODO Web Research (Playwright browsing)
|
||||
Headless Chromium via Python bridge.
|
||||
Text extraction, screenshots, Gemini Web UI automation.
|
||||
|
||||
*** TODO Memex Management (PARA lifecycle)
|
||||
Archive DONE tasks, suggest refiling.
|
||||
Detect orphaned nodes.
|
||||
PARA/Zettelkasten maintenance.
|
||||
|
||||
*** v0.7.0: Visual Grounding & MCP Bridge
|
||||
|
||||
Multimodal visual interaction and ecosystem-wide tool compatibility.
|
||||
|
||||
** Tasks
|
||||
|
||||
*** TODO Computer Use / Vision
|
||||
Allow the agent to request host OS or browser screenshots.
|
||||
Analyze UI and issue precise X/Y coordinate click/type commands via X11/Wayland bridge.
|
||||
|
||||
*** TODO MCP Gateway Bridge
|
||||
Lisp-native client for the Model Context Protocol.
|
||||
Connect Passepartout to external tools and data sources.
|
||||
|
||||
*** v0.8.0: The Evaluation Harness
|
||||
|
||||
Automated benchmarking to mathematically prove the agent's reasoning capabilities.
|
||||
|
||||
** Tasks
|
||||
|
||||
*** TODO SWE-Bench Harness
|
||||
Automated pipeline that clones repositories and feeds GitHub issues.
|
||||
Track multi-step resolution trajectory, run tests, and score success.
|
||||
|
||||
*** v1.0.0: SOTA Parity
|
||||
|
||||
Feature-complete agent competitive with commercial agents. All features from v0.2.0 through v0.8.0 combined, verified, and tested end-to-end.
|
||||
|
||||
| Area | Parity Target |
|
||||
|------|--------------|
|
||||
| Self-improvement | Claude Code self-debug |
|
||||
| Planning | ULTRAPLAN equivalent |
|
||||
| Tool ecosystem | 10+ cognitive tools |
|
||||
| Context window | Semantic search + scope segmentation |
|
||||
| Safety | 6 Policy invariants + formal verification |
|
||||
| Multi-step tasks | Task trees with terminal states |
|
||||
| Code editing | Full file read/write via org manipulation |
|
||||
| Memory | Vector recall in memory-object |
|
||||
| Emacs integration | Full org-mode control (exceeds Claude Code) |
|
||||
| Autonomy | 100% local capable (exceeds Claude Code) |
|
||||
|
||||
*** v2.0.0: Lisp Machine Emergence
|
||||
|
||||
From Lisp-using agent to true Lisp machine. Agent IS the Emacs process.
|
||||
|
||||
- Lish: Lisp editor — Org-mode as IDE. Org-babel for interactive evaluation. Full REPL in TUI.
|
||||
- Lish: Shell replacement — Lisp-based shell that speaks plists. Org-mode buffers as file system.
|
||||
|
||||
*** v3.0.0: Neurosymbolic Maturity
|
||||
|
||||
Deterministic planner takes the wheel. LLM relegated to semantic translation.
|
||||
|
||||
- Deterministic planner: Pure Lisp task scheduler. No LLM needed for scheduling.
|
||||
- Self-correcting gates: Gates learn from false positives (user override patterns).
|
||||
|
||||
*** v4.0.0: AI Stack Internalized
|
||||
|
||||
The agent understands its own weights. No external inference.
|
||||
|
||||
- Llama.cpp in Lisp: FFI binding. No Python subprocess. Pure Common Lisp inference.
|
||||
- Weights as sexps: Neural weights as Lisp data structures. Homoiconic model introspection.
|
||||
|
||||
*** v5.0.0: True Agency
|
||||
|
||||
World models, temporal reasoning, goal persistence across restarts.
|
||||
|
||||
- World models: Predictive models of user behavior, project dynamics, system state.
|
||||
- Temporal reasoning: Scheduling, deadlines, elapsed duration awareness.
|
||||
- Goal persistence: Goals survive restarts. Long-term projects in memory-objects.
|
||||
@@ -1,21 +1,34 @@
|
||||
#+TITLE: OpenCortex User Manual
|
||||
#+AUTHOR: OpenCortex Contributors
|
||||
#+TITLE: Passepartout User Manual
|
||||
#+AUTHOR: Passepartout Contributors
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :docs:manual:
|
||||
|
||||
* Introduction
|
||||
Welcome to OpenCortex v0.1.0 (The Autonomous Foundation). OpenCortex is a neurosymbolic AI agent and a Lisp Machine operating system designed to autonomously maintain your Memex (knowledge base) and interact with you via multiple, equal-citizen interfaces.
|
||||
Welcome to Passepartout v0.1.0 (The Autonomous Foundation). Passepartout is a neurosymbolic AI agent and a Lisp Machine operating system designed to autonomously maintain your Memex (knowledge base) and interact with you via multiple, equal-citizen interfaces.
|
||||
|
||||
* Installation
|
||||
OpenCortex is bootstrapped via a single shell script.
|
||||
Passepartout is bootstrapped via a single shell script.
|
||||
|
||||
** Quick start (curl)
|
||||
|
||||
#+begin_src bash
|
||||
git clone ssh://git@10.10.10.201:2222/amr/opencortex.git
|
||||
cd opencortex
|
||||
./opencortex.sh setup
|
||||
curl -fsSL https://raw.githubusercontent.com/amrgharbeia/passepartout/main/passepartout.sh | bash -s configure
|
||||
#+end_src
|
||||
|
||||
This process will install SBCL, Quicklisp, and prompt you to create a `.env` file for your API keys.
|
||||
** From a clone
|
||||
|
||||
#+begin_src bash
|
||||
git clone https://github.com/amrgharbeia/passepartout.git ~/projects/passepartout
|
||||
~/projects/passepartout/passepartout.sh configure
|
||||
#+end_src
|
||||
|
||||
Both methods will:
|
||||
1. Install system dependencies (SBCL, Emacs, git, curl, socat — detected for Debian or Fedora)
|
||||
2. Install Quicklisp (Common Lisp package manager)
|
||||
3. Tangle literate Org sources into runnable Lisp
|
||||
4. Launch the interactive setup wizard (LLM providers, gateways)
|
||||
|
||||
If you already have Emacs installed, the installer skips it and uses your existing installation.
|
||||
|
||||
* Configuration
|
||||
The system is configured via a `.env` file in the project root. Essential variables include:
|
||||
@@ -24,33 +37,88 @@ The system is configured via a `.env` file in the project root. Essential variab
|
||||
- `PROVIDER_CASCADE`: The fallback order for LLM providers (e.g., `openrouter,ollama,anthropic`).
|
||||
- `MEMEX_DIR`: The absolute path to your knowledge base (defaults to `~/memex`).
|
||||
|
||||
* Interacting with OpenCortex
|
||||
* Interacting with Passepartout
|
||||
Because of the Unified Envelope Architecture, the kernel treats all clients as interchangeable. You must first boot the background daemon:
|
||||
|
||||
#+begin_src bash
|
||||
./opencortex.sh --boot &
|
||||
./passepartout.sh --boot &
|
||||
#+end_src
|
||||
|
||||
** Terminal User Interface (TUI)
|
||||
For a rich, split-pane terminal experience:
|
||||
#+begin_src bash
|
||||
./opencortex.sh tui
|
||||
./passepartout.sh tui
|
||||
#+end_src
|
||||
|
||||
** Command Line Interface (CLI)
|
||||
For raw, pipe-friendly interaction:
|
||||
#+begin_src bash
|
||||
./opencortex.sh cli
|
||||
./passepartout.sh cli
|
||||
#+end_src
|
||||
|
||||
** Emacs Integration
|
||||
OpenCortex functions as your "foveal vision" inside Emacs.
|
||||
Passepartout functions as your "foveal vision" inside Emacs.
|
||||
1. Ensure `org-agent.el` is loaded.
|
||||
2. Run `M-x opencortex-connect`.
|
||||
3. Interact via the `*opencortex-chat*` buffer.
|
||||
2. Run `M-x passepartout-connect`.
|
||||
3. Interact via the `*passepartout-chat*` buffer.
|
||||
|
||||
* The Memex Structure
|
||||
OpenCortex assumes a local folder structure representing your "Memex".
|
||||
Passepartout assumes a local folder structure representing your "Memex".
|
||||
- Core memories and identities are mapped to Org-mode files.
|
||||
- The `Scribe` background worker distills chronological logs into structured Zettelkasten notes.
|
||||
- The `Gardener` continuously repairs broken links and flags orphaned nodes.
|
||||
- The `Gardener` continuously repairs broken links and flags orphaned nodes.
|
||||
|
||||
* Deployment
|
||||
|
||||
** Bare metal (Debian / Fedora)
|
||||
|
||||
The ~configure~ command supports both Debian-based (Ubuntu, Pop, Mint) and Fedora-based (RHEL, Rocky) distributions. It detects your distro automatically and installs the correct packages.
|
||||
|
||||
#+begin_src bash
|
||||
./passepartout.sh configure # interactive
|
||||
./passepartout.sh configure --non-interactive # headless
|
||||
./passepartout.sh configure --with-firewall # also open port 9105
|
||||
#+end_src
|
||||
|
||||
After configuration, you can re-run ~configure~ any time to add providers or link gateways.
|
||||
|
||||
** systemd service (auto-start on boot)
|
||||
|
||||
#+begin_src bash
|
||||
./passepartout.sh install service
|
||||
#+end_src
|
||||
|
||||
Installs a user-level systemd unit that starts the daemon on login. Logs are available via ~journalctl --user -u passepartout.service -f~.
|
||||
|
||||
To remove:
|
||||
|
||||
#+begin_src bash
|
||||
./passepartout.sh uninstall service
|
||||
#+end_src
|
||||
|
||||
** Docker
|
||||
|
||||
A Debian-based Docker image is provided for containerized deployment.
|
||||
|
||||
#+begin_src bash
|
||||
cd infrastructure/docker
|
||||
docker-compose up -d
|
||||
#+end_src
|
||||
|
||||
This builds an image from ~debian:trixie-slim~ with all dependencies pre-installed. The memex directory is mounted from the host.
|
||||
|
||||
** Backup
|
||||
|
||||
#+begin_src bash
|
||||
./passepartout.sh backup ~/my-backup.tar.gz
|
||||
#+end_src
|
||||
|
||||
Backs up the config, data, and memex directories.
|
||||
|
||||
** Restore
|
||||
|
||||
#+begin_src bash
|
||||
./passepartout.sh restore ~/my-backup.tar.gz
|
||||
#+end_src
|
||||
|
||||
Restores from a backup file. Run ~passepartout doctor~ afterward to verify integrity.
|
||||
@@ -1,42 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Micro-Loader & Deterministic Boot Sequence
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:boot:loader:topological-sort:autonomy:
|
||||
|
||||
* Executive Summary
|
||||
Refactored the arbitrary skill loading mechanism into a robust **Micro-Loader**. The system now calculates a deterministic boot sequence based on `#+DEPENDS_ON:` tags and protects the harness from malformed or hanging skills via package-based jailing and execution timeouts.
|
||||
|
||||
* 1. Issue: Fragile Load Order
|
||||
** Symptoms
|
||||
Skills that depended on functions or variables from other skills would randomly fail to load depending on the filesystem's directory traversal order.
|
||||
** Root Cause
|
||||
`initialize-all-skills` used a simple `dolist` over `uiop:directory-files`, which has no semantic awareness of inter-skill dependencies.
|
||||
** Resolution
|
||||
1. **Metadata Scanning:** Implemented `parse-skill-metadata` to extract `:ID:` and `#+DEPENDS_ON:` without executing code.
|
||||
2. **Topological Sort:** Implemented a DFS-based `topological-sort-skills` to guarantee that prerequisites are loaded before their dependents.
|
||||
3. **Circular Detection:** Added explicit detection and error reporting for circular dependency loops.
|
||||
|
||||
* 2. Issue: Shared State Corruption (Brain Rot)
|
||||
** Symptoms
|
||||
Variables or functions with the same name in different skills would silently overwrite each other, causing unpredictable behavior.
|
||||
** Root Cause
|
||||
All skills were being evaluated directly into the `opencortex` package.
|
||||
** Resolution
|
||||
**Package-Based Jailing:** Each skill is now evaluated within its own dedicated, shadowed package (e.g., `OPENCORTEX.SKILLS.ORG-SKILL-CHAT`). This ensures logical isolation while still allowing access to kernel exports.
|
||||
|
||||
* 3. Issue: Boot Stall (The Hanging Skill)
|
||||
** Symptoms
|
||||
A single skill with an infinite loop or heavy synchronous initialization could hang the entire agent during startup.
|
||||
** Root Cause
|
||||
Skill loading was strictly synchronous and blocking on the main thread.
|
||||
** Resolution
|
||||
**Execution Timeouts:** Implemented `load-skill-with-timeout`, which wraps the loader in a monitored thread. If a skill takes longer than 5 seconds to initialize, the loader terminates the thread, jails the failure, and continues with the rest of the boot sequence.
|
||||
|
||||
* 4. opencortex Mandate Alignment
|
||||
** Evolutionary Kernel
|
||||
The boot sequence is now a verifiable, mathematical process rather than a side-effect of filesystem organization.
|
||||
** Literate Granularity
|
||||
The `org-skill-skills.org` source was refactored into a strictly granular "one definition per block" format.
|
||||
|
||||
* 5. Permanent Learnings
|
||||
- **Reverse Topological Order:** Remember that a DFS-based sort with `push` needs an `nreverse` to place dependencies at the front of the list.
|
||||
- **Path Portability:** Use `uiop:getcwd` instead of `pwd` for more reliable path resolution across different Lisp implementations and OSes.
|
||||
@@ -1,33 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Deterministic Engine Bouncer & Authorization Gate
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:bouncer:authorization:autonomy:security:
|
||||
|
||||
* Executive Summary
|
||||
Implemented the "Planning Mode" Bouncer to intercept high-risk Probabilistic Engine proposals (e.g., shell commands, Lisp evaluation). The system now forces these actions into an asynchronous "Flight Plan" Org node for manual Autonomous approval, fulfilling the "everything is a node" and high-integrity mandates.
|
||||
|
||||
* 1. Issue: Automated High-Risk Execution
|
||||
** Symptoms
|
||||
Probabilistic Engine proposals involving `shell` or `eval` were executed immediately upon passing the `decide` gate's safety harness. This lacked human-in-the-loop oversight for irreversible or complex operations.
|
||||
** Root Cause
|
||||
Architecture gap. The system lacked an authorization state between "Safe" and "Executed".
|
||||
** Resolution
|
||||
1. **Interceptor:** Added `bouncer-check` to `deterministic.lisp`. It flags high-risk actions that lack the `:approved t` property.
|
||||
2. **Asynchronous Event:** If flagged, the harness emits an `:approval-required` event.
|
||||
3. **Flight Plan Skill:** Created `org-skill-bouncer.org` to:
|
||||
- Catch the event and create a serialized Org node with state `PLAN`.
|
||||
- Monitor the Memory for `APPROVED` states.
|
||||
- Re-inject approved actions with the `:approved t` bypass flag.
|
||||
|
||||
* 2. Design Decision: Org-native Approval
|
||||
** Requirement
|
||||
Align with "Homoiconic Memory" and "Lisp Machine Autonomousty".
|
||||
** Selected Path
|
||||
State-Based Approval (Org-native).
|
||||
- *Pros:* Auditable, asynchronous, utilizes existing Org-mode workflows.
|
||||
- *Cons:* Slightly more latency than an interactive prompt.
|
||||
** Alignment
|
||||
Ensures that the agent's "Flight Plans" are first-class citizens in the Memex, allowing the Autonomous to review and approve them using standard GTD tools.
|
||||
|
||||
* 3. Permanent Learnings
|
||||
- **Serial Bypass:** Always include a specific bypass flag (e.g., `:approved t`) when re-injecting intercepted actions to prevent infinite interception loops.
|
||||
- **Heartbeat Listeners:** Periodic scanning of the Memory for state transitions is an effective way to implement asynchronous authorization gates without blocking the harness.
|
||||
@@ -1,36 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Lisp-Native Formal Verification Gate
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:security:formal-verification:autonomy:
|
||||
|
||||
* Executive Summary
|
||||
Implemented a Lisp-Native Deterministic Prover to replace heuristic whitelisting with formal security invariants. This ensures that every high-impact action (shell, file I/O) is mathematically proven safe against the Autonomous's core mandates.
|
||||
|
||||
* 1. Architectural Shift: Native vs. External
|
||||
** Issue
|
||||
The initial draft suggested using `Z3`, an external SMT solver. However, `Z3` was not available in the environment and would add significant complexity/bloat to the Docker image.
|
||||
** Resolution
|
||||
Leveraged Common Lisp's inherent strength in symbol manipulation to build a **Lisp-Native Prover**. Invariants are defined as high-order predicates that operate on the structure of proposed actions. This provides a self-contained, high-performance verification layer.
|
||||
|
||||
* 2. Issue: Dependency Fragility
|
||||
** Symptoms
|
||||
System failed to load with `Package STR does not exist`.
|
||||
** Root Cause
|
||||
Incorrect assumption about the Quicklisp system name vs. the package name. The library is `cl-str` but the Quicklisp system is `str` and the package is `str`.
|
||||
** Resolution
|
||||
1. Updated `opencortex.asd` to depend on `:str`.
|
||||
2. Updated all source code and literate notes to use the `str:` prefix.
|
||||
3. Verified via explicit `ql:quickload` in the test runner.
|
||||
|
||||
* 3. Formal Invariants Implemented
|
||||
- **Path Confinement:** Deterministically proves that any file operation or absolute path in a shell command is strictly within the `/home/user/memex` root.
|
||||
- **No Network Exfiltration:** Prevents the shell from invoking common exfiltration tools (`nc`, `ssh`, etc.) by inspecting the parsed command structure.
|
||||
|
||||
* 4. opencortex Mandate Alignment
|
||||
** Soundness over Heuristics
|
||||
By moving to formal invariants, we have moved from "blacklisting bad things" to "proving safety." Any action that cannot be proven to satisfy all invariants is denied by default.
|
||||
** Literate Granularity
|
||||
The `org-skill-formal-verification.org` file follows the "one definition per block" mandate, ensuring that the logic of each invariant is individually documented and verifiable.
|
||||
|
||||
* 5. Permanent Learnings
|
||||
- **Tooling Independence:** Whenever possible, prefer native Lisp logic over external binaries for core security gates to reduce the attack surface and deployment complexity.
|
||||
- **Environment Consistency:** Always use `(setf (uiop:getenv ...) ...)` for portable environment manipulation in tests.
|
||||
@@ -1,40 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Matrix Gateway & Communication Track Completion
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:gateway:matrix:chat:autonomy:
|
||||
|
||||
* Executive Summary
|
||||
Successfully implemented the third and final external communication channel (Matrix) for OpenCortex v1.0. Resolved integration issues related to case-sensitivity in JSON keys and strict header requirements in `dexador`.
|
||||
|
||||
* 1. Issue: Symbol Casing in JSON Keys
|
||||
** Symptoms
|
||||
The `TEST-MATRIX-INBOUND-NORMALIZATION` test failed because `room-id` was being extracted as `"!ROOM:HS.ORG"` (uppercase) instead of `"!room:hs.org"`.
|
||||
** Root Cause
|
||||
Common Lisp's default reader converts symbol names to uppercase. When `(string car-of-alist)` was called on a symbol generated by `cl-json`, it produced an uppercase string.
|
||||
** Resolution
|
||||
Updated the implementation to use `(string-downcase (string ...))` for room IDs and other case-sensitive Matrix identifiers.
|
||||
|
||||
* 2. Issue: Since Token Extraction Failure
|
||||
** Symptoms
|
||||
The sync loop failed to update the `*matrix-since-token*`, causing duplicate message processing risk.
|
||||
** Root Cause
|
||||
Anticipating `:next-batch` but receiving `:next--batch` (or vice versa) due to inconsistent `cl-json` behavior across different environments or structures.
|
||||
** Resolution
|
||||
Implemented a robust `(or (cdr (assoc :next-batch json)) (cdr (assoc :next--batch json)))` lookup to handle both hyphenation styles.
|
||||
|
||||
* 3. Issue: Type Error in Authorization Headers
|
||||
** Symptoms
|
||||
`dex:put` crashed with a `TYPE-ERROR`.
|
||||
** Root Cause
|
||||
I was passing a single string or an incorrectly nested list where `dexador` expected a strict alist of header pairs `(("Key" . "Value") ...)`.
|
||||
** Resolution
|
||||
Standardized all gateway HTTP calls to use proper alist nesting for headers.
|
||||
|
||||
* 4. Completion: Communication Track
|
||||
With Telegram, Signal, and Matrix gateways now verified and passing tests, the OpenCortex has achieved full multi-channel parity.
|
||||
- **Telegram:** Polling via Bot API.
|
||||
- **Signal:** Wrapping `signal-cli`.
|
||||
- **Matrix:** Polling via `/sync` Client API.
|
||||
|
||||
* 5. Permanent Learnings
|
||||
- **Case Sensitivity:** Matrix IDs (rooms, users) are case-sensitive; Lisp symbols are not. Always force downcasing or use strings for storage.
|
||||
- **Header Alists:** Always use dotted pairs `("Key" . "Value")` for `dexador` headers.
|
||||
@@ -1,33 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Signal Gateway & Multi-Channel Chat
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:gateway:signal:chat:autonomy:
|
||||
|
||||
* Executive Summary
|
||||
Successfully implemented the second external communication channel (Signal) using `signal-cli`. Further hardened the multi-channel chat logic and resolved JSON mapping discrepancies between Common Lisp and external CLI outputs.
|
||||
|
||||
* 1. Issue: JSON Key Mapping Mismatch
|
||||
** Symptoms
|
||||
The `TEST-SIGNAL-INBOUND-NORMALIZATION` test failed despite the mock JSON appearing correct.
|
||||
** Root Cause
|
||||
`cl-json` default behavior for decoding. It converts camelCase keys from JSON (e.g., `dataMessage`) into kebab-case keywords in Lisp (e.g., `:DATA-MESSAGE`). I had incorrectly anticipated `:DATA--MESSAGE` or `:DATA_MESSAGE`.
|
||||
** Resolution
|
||||
1. **Diagnostic:** Added debug output to the test suite to inspect the exact plist structure returned by `cl-json`.
|
||||
2. **Correction:** Updated both the implementation and the literate note to use the correct `:DATA-MESSAGE` and `:SOURCE` keywords.
|
||||
|
||||
* 2. Implementation: Signal-CLI Wrapper
|
||||
** Strategy
|
||||
Unlike Telegram's HTTP API, Signal requires a local binary (`signal-cli`).
|
||||
- **Sensor:** Uses `uiop:run-program` with `receive --json` in a polling loop (5s interval).
|
||||
- **Actuator:** Uses `uiop:run-program` with `send -m <text> <recipient>`.
|
||||
** Security
|
||||
The system uses the pre-configured Signal account `+13322690326` discovered in the user's memex.
|
||||
|
||||
* 3. Alignment with opencortex Mandates
|
||||
** Literate Granularity
|
||||
Strictly adhered to the "one definition per block" mandate throughout the new `org-skill-gateway-signal.org` file.
|
||||
** Verification
|
||||
The `gateway-signal-suite` (10 checks) provides full coverage for inbound parsing and outbound command generation.
|
||||
|
||||
* 4. Permanent Learnings
|
||||
- **JSON Semantics:** Always verify the specific keyword transformation rules of the JSON library when dealing with external CLI outputs.
|
||||
- **Process Robustness:** `uiop:run-program` is the reliable standard for CLI-based gateways in SBCL.
|
||||
@@ -1,43 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Telegram Gateway & Channel-Aware Chat
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:gateway:telegram:chat:autonomy:
|
||||
|
||||
* Executive Summary
|
||||
Successfully implemented the first external communication channel (Telegram) and decoupled the Chat Agent from its Emacs-centric roots. Resolved significant load-order and dependency issues identified during integration.
|
||||
|
||||
* 1. Issue: Undefined Foundational Functions
|
||||
** Symptoms
|
||||
During compilation, `gateway-telegram.lisp` failed with `UNDEFINED-FUNCTION` for `register-actuator` and `harness-log`.
|
||||
** Root Cause
|
||||
Poorly scoped foundational functions. These were defined in `core.lisp` (the loop orchestrator), which was loaded *after* the gateways in `opencortex.asd`. This created a "Circular Intention" where the gateways needed the harness to exist before the harness could load the gateways.
|
||||
** Resolution
|
||||
1. **Relocation:** Moved `*actuator-registry*` and `register-actuator` to `communication.lisp` (the foundation).
|
||||
2. **Reordering:** Adjusted `opencortex.asd` to load `core.lisp` (containing the stimulus loop) immediately after the deterministic gates but before the physical sensors (gateways).
|
||||
|
||||
* 2. Issue: Hardcoded Chat UI
|
||||
** Symptoms
|
||||
The `Chat Agent` could only respond via Emacs buffer insertion, rendering it useless for external channels like Telegram.
|
||||
** Root Cause
|
||||
Architectural myopia. The original chat skill assumed the user was always in front of Emacs.
|
||||
** Resolution
|
||||
Refactored `org-skill-chat` to be **Channel-Aware**:
|
||||
- It now extracts `:channel` and `:chat-id` from the inbound stimulus.
|
||||
- It dynamically generates the Probabilistic Engine mandate, instructing the LLM to use the appropriate `:target` (e.g., `:telegram`) based on the conversation context.
|
||||
|
||||
* 3. Side-Issue: UIOP Portability
|
||||
** Symptoms
|
||||
Tests failed with `Symbol "SETENV" not found in the UIOP/DRIVER package`.
|
||||
** Root Cause
|
||||
Misinterpretation of the `UIOP` API. `setenv` is not a standard export; the portable way is using `(setf (uiop:getenv ...) ...)`.
|
||||
** Resolution
|
||||
Updated all test environment setup to use the `setf` accessor.
|
||||
|
||||
* 4. opencortex Mandate Alignment
|
||||
** Autonomous Boundary
|
||||
By moving the Telegram API logic to a user-space skill and communicating with the core via standard stimuli, we have respected the microkernel boundary.
|
||||
** Homoiconic Memory
|
||||
All Telegram interactions are now logged as `:chat-message` events, ensuring the agent's history is unified regardless of the platform.
|
||||
|
||||
* 5. Permanent Learnings
|
||||
- **Foundation First:** Registries and logging macros must reside in the most foundational layers (`protocol` or `package`) to avoid load-order fragility.
|
||||
- **Instruct the Actuator:** When adding new channels, always update the Chat Agent's neural prompt so it knows how to "speak" back through the new interface.
|
||||
@@ -1,30 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Containerized Infrastructure (Docker)
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:docker:deployment:infrastructure:autonomy:
|
||||
|
||||
* Executive Summary
|
||||
Standardized the `opencortex` execution environment by creating a production-grade Docker infrastructure. This ensures that all system dependencies, including the Lisp runtime and external binaries like `signal-cli`, are locked down and portable.
|
||||
|
||||
* 1. Architectural Intent: The "Clean Room" Model
|
||||
** Problem
|
||||
The `opencortex` was relying on host-local binaries (`sbcl`, `signal-cli`) and manually configured Quicklisp dists. This made deployment to other environments (e.g., a VPS or a Autonomous Home Server) fragile and prone to version drift.
|
||||
** Solution
|
||||
1. **Dockerfile:** Created a multi-step build process that installs Debian Bookworm, SBCL, Java, and `signal-cli 0.14.0`.
|
||||
2. **Pre-Caching:** The build process triggers a `ql:quickload` of the `:opencortex` system, ensuring all Lisp dependencies are pre-downloaded and stored in the image layer, drastically reducing startup time.
|
||||
3. **Compose Orchestration:** Standardized the runtime via `docker-compose.yml`, which handles volume mounting of the user's `memex` directory and injection of `.env` secrets.
|
||||
|
||||
* 2. Volume Mapping & Persistence
|
||||
** Strategy
|
||||
To maintain the "Autonomous" mandate, the agent's code is isolated, but its memory (the `memex`) remains on the host.
|
||||
- **Mapping:** `../..` (host) -> `/memex` (container).
|
||||
- **State:** Created a named Docker volume `signal-state` to ensure that `signal-cli` identities and cryptographic keys survive container restarts and image updates.
|
||||
|
||||
* 3. Alignment with opencortex Mandates
|
||||
** Evolutionary Completion
|
||||
By moving to Docker, we have achieved "Evolutionary Completion" for the deployment track. The system is no longer a collection of scripts; it is a deployable appliance.
|
||||
** Documentation
|
||||
A new `Deployment Guide` was added to `docs/deployment.org` to ensure standard operating procedures are preserved.
|
||||
|
||||
* 4. Permanent Learnings
|
||||
- **Lisp Build Layers:** Always push the system to the ASDF registry and quickload during Docker build to bake dependencies into the image.
|
||||
- **Compose Locality:** Placing the `docker-compose.yml` inside the `projects/opencortex/` folder keeps infrastructure code close to the implementation logic.
|
||||
@@ -1,33 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Asynchronous Lisp Repair Syntax Gate
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:lisp:repair:decoupling:architecture:autonomy:
|
||||
|
||||
* Executive Summary
|
||||
Reimplemented the `org-skill-lisp-repair` to align with the "Autonomous Boundary" mandate. The previously synchronous, core-blocking repair logic has been replaced with an asynchronous, event-driven architecture using the Reactive Signal Pipeline.
|
||||
|
||||
* 1. Issue: Core Bloat & Synchronous Coupling
|
||||
** Symptoms
|
||||
The initial implementation of the Lisp Repair gate placed a `handler-case` and a dynamic function call (`repair-lisp-syntax`) directly inside the core `think` function (`probabilistic.lisp`). This forced the core to wait for repairs and made it "aware" of specific repair logic.
|
||||
** Root Cause
|
||||
Architectural shortcutting. By placing repair logic in the core execution path, we violated the microkernel principle which mandates that the core should be a "dumb" signal processor.
|
||||
** Resolution
|
||||
1. **Refactored Core:** `think` now only emits a `:syntax-error` stimulus if parsing fails. It no longer attempts to repair.
|
||||
2. **Asynchronous Skill:** `skill-lisp-repair` now triggers on the `:syntax-error` event. It performs the repair and returns the corrected action, which is then dispatched by the pipeline.
|
||||
|
||||
* 2. Side-Issue: Nested Signal Payloads
|
||||
** Symptoms
|
||||
`TYPE-ERROR` during testing when extracting the broken code from the stimulus.
|
||||
** Root Cause
|
||||
Mismatched expectations of signal nesting. The skill expected the code at `(getf context :payload)`, but in the `decide-gate`, `context` is the full signal, and the error details were nested inside the `:candidate` field of that signal.
|
||||
** Resolution
|
||||
Updated the deterministic logic to correctly traverse the nested signal structure: `(getf (getf context :candidate) :payload)`.
|
||||
|
||||
* 3. opencortex Mandate Alignment
|
||||
** Autonomous Boundary
|
||||
The core is now strictly a parser. Repair is an optional, user-space service.
|
||||
** Reactive Signal Pipeline
|
||||
Leveraged the pipeline's ability to re-inject `EVENT` signals to flatten the recursion of the repair loop.
|
||||
|
||||
* 4. Permanent Learnings
|
||||
- **Emit, Don't Call:** In a microkernel, if a non-fatal error occurs, always emit a signal rather than calling a recovery function. This allows the system to remain asynchronous and modular.
|
||||
- **Signal Inspection:** When writing deterministic gates, always verify the exact shape of the `context` signal being passed by the harness to avoid nesting errors.
|
||||
@@ -1,39 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Playwright-Python Bridge (High-Fidelity Browsing)
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:intelligence:browsing:automation:autonomy:
|
||||
|
||||
* Executive Summary
|
||||
Successfully implemented a high-fidelity browsing bridge using Playwright and Python. This allows the `opencortex` to interact with modern, JavaScript-rendered web applications that were previously inaccessible via simple HTTP clients.
|
||||
|
||||
* 1. Architectural Strategy: The I/O Bridge
|
||||
** Problem
|
||||
Common Lisp lacks a mature, native Playwright implementation. Direct bindings are complex and fragile.
|
||||
** Resolution
|
||||
Implemented a **JSON-over-STDIO Bridge**.
|
||||
- A standalone Python script (`browser-bridge.py`) manages the Playwright lifecycle and Chromium instance.
|
||||
- The Lisp kernel communicates with this script using `uiop:run-program`, passing parameters via `stdin` and receiving structured results via `stdout`. This provides a stable, decoupled interface.
|
||||
|
||||
* 2. Environment & Dependency Management
|
||||
** Issue
|
||||
Playwright requires a specific version of Chromium and several system-level libraries not present in the base Debian image.
|
||||
** Resolution
|
||||
Updated the `Dockerfile` to:
|
||||
1. Install Python3, pip, and venv.
|
||||
2. Create a virtual environment for isolated dependency management.
|
||||
3. Install the `playwright` package and execute `playwright install --with-deps chromium` during the image build. This ensures the production container is ready for high-fidelity browsing immediately upon startup.
|
||||
|
||||
* 3. Cognitive Tooling
|
||||
Created the `:browser` cognitive tool, which exposes three primary capabilities to Probabilistic Engine:
|
||||
- **Navigation:** Full JS rendering and waiting for network idle.
|
||||
- **Extraction:** Targeted text retrieval via CSS selectors.
|
||||
- **Vision:** Base64-encoded screenshot capture for future multimodal processing.
|
||||
|
||||
* 4. opencortex Mandate Alignment
|
||||
** Zero-Bloat (Managed)
|
||||
While adding Playwright increases the image size, it is a "Complexity Earned" trade-off that dramatically expands the agent's capability frontier.
|
||||
** Literate Granularity
|
||||
The `org-skill-playwright.org` file strictly follows the "one definition per block" mandate.
|
||||
|
||||
* 5. Permanent Learnings
|
||||
- **Inter-Process JSON:** JSON is the ideal lingua franca for Lisp-Python bridges.
|
||||
- **Path Portability:** Always use `uiop:native-namestring` when passing Lisp paths to external shell commands to ensure OS compatibility.
|
||||
@@ -1,40 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Individual Provider Track Verification
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:providers:llm:testing:autonomy:
|
||||
|
||||
* Executive Summary
|
||||
Verified the unified LLM gateway implementation for all 6 individual provider tracks (Anthropic, Gemini, Groq, OpenAI, OpenRouter, Ollama). Identified and resolved critical parsing failures in the Gemini track and integration gaps in the system build definition.
|
||||
|
||||
* 1. Issue: Fragile Response Parsing (Gemini)
|
||||
** Symptoms
|
||||
Gemini API responses were returning `NIL` content during mocked unit tests, despite the JSON structure being seemingly correct.
|
||||
** Root Cause
|
||||
Recursive `assoc` / `car` / `cdr` chains were hardcoded and brittle. Specifically, the Gemini extraction logic was incorrectly attempting to treat a single alist pair as a list of pairs, causing `assoc` to fail on the `:TEXT` key.
|
||||
** Resolution
|
||||
Implemented a robust `get-nested` helper function that safely traverses both nested objects (alists) and arrays (lists of alists). This normalized the extraction logic across all providers.
|
||||
|
||||
* 2. Issue: Decoupled Build Configuration
|
||||
** Symptoms
|
||||
Provider logic was present in the codebase but inaccessible during tests and runtime.
|
||||
** Root Cause
|
||||
The `credentials-vault.lisp` and `llm-gateway.lisp` files (consolidated in a previous session) were never added to the `opencortex.asd` system definition. Furthermore, an incorrect loading order caused `UNDEFINED-FUNCTION` errors for `register-probabilistic-backend`.
|
||||
** Resolution
|
||||
1. Added both files to `opencortex.asd`.
|
||||
2. Enforced strict loading order: `probabilistic` (defines registry) -> `credentials-vault` -> `llm-gateway` (uses registry).
|
||||
|
||||
* 3. Issue: Credential Key Mismatch
|
||||
** Symptoms
|
||||
Gemini requests failed with "API Key missing" even when environment variables were set.
|
||||
** Root Cause
|
||||
`llm-gateway` requested secrets for the `:gemini-api` provider, but the `credentials-vault` fallback logic only recognized the `:gemini` keyword.
|
||||
** Resolution
|
||||
Updated `vault-get-secret` to map both `:gemini` and `:gemini-api` to the same `GEMINI_API_KEY` environment variable.
|
||||
|
||||
* 4. opencortex Mandate Alignment
|
||||
** Invariant Check
|
||||
- *High-Integrity Memory:* All individual provider tracks are now backed by automated unit tests (`llm-gateway-tests.lisp`).
|
||||
- *Literate Programming:* Updated `org-skill-llm-gateway.org` to reflect the improved `get-nested` utility.
|
||||
|
||||
* 5. Permanent Learnings
|
||||
- **Tooling vs Source:** Tangled `.lisp` files are not enough; always ensure new modules are registered in the `.asd` file to be part of the official kernel build.
|
||||
- **Robustness over Brevity:** Use abstraction helpers like `get-nested` instead of deep `car/cdr` chains when dealing with external JSON structures that may have varying array/object nesting.
|
||||
@@ -1,40 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Autonomous Self-Fix Loop Verification
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:self-fix:autonomy:testing:
|
||||
|
||||
* Executive Summary
|
||||
Verified the autonomous repair capability of the `Self-Fix Agent`. The system successfully detected a deterministic type error in a secondary skill, initiated a repair request, and programmatically patched the source code via the `:repair-file` tool.
|
||||
|
||||
* 1. Issue: Self-Fix Mechanism Verification
|
||||
** Symptoms
|
||||
Manual verification was required to prove that `org-skill-self-fix` could transition from "Thinking" about a bug to "Acting" on the file system.
|
||||
** Root Cause
|
||||
N/A (Deterministic test injection).
|
||||
** Resolution
|
||||
Created `self-fix-tests.lisp` which:
|
||||
1. Generates `org-skill-broken-math.org` with a `(+ 1 "two")` bug.
|
||||
2. Triggers the bug to produce a `PIPELINE CRASH`.
|
||||
3. Injects a `:repair-request` stimulus.
|
||||
4. Executes `self-fix-apply` to replace the bug with `(+ 1 2)`.
|
||||
5. Verifies the file content and successful hot-reload.
|
||||
|
||||
* 2. Side-Issue: ASDF Configuration Fragility
|
||||
** Symptoms
|
||||
Repeated `LOAD-SYSTEM-DEFINITION-ERROR` and "unmatched close parenthesis" errors during test integration.
|
||||
** Root Cause
|
||||
Complexity in the `:components` nesting of `opencortex.asd` led to repeated syntax errors when using automated editing tools. The deep nesting made manual paren counting prone to "off-by-one" errors.
|
||||
** Resolution
|
||||
Refactored `opencortex.asd` to use a **Flat Component Structure**.
|
||||
- *Before:* `:components ((:module "src" :components (...)))`
|
||||
- *After:* `:components ((:file "src/package") ...)`
|
||||
This eliminates unnecessary nesting levels and drastically reduces the surface area for syntax errors.
|
||||
|
||||
* 3. opencortex Mandate Alignment
|
||||
** Invariant Check
|
||||
- *Lisp Machine Autonomousty:* Verification utilized hot-reloading (`load-skill-from-org`) without restarting the SBCL image.
|
||||
- *Literate Programming:* Updated `org-skill-self-fix.org` to match the finalized `self-fix.lisp` logic.
|
||||
- *Institutional Memory:* This RCA documents the decision to flatten the `.asd` structure to prevent future "Parenthesis Hell" incidents.
|
||||
|
||||
* 4. Permanent Learnings
|
||||
- **Flatten Configuration:** Keep `defsystem` definitions as flat as possible. The overhead of `:module` blocks often outweighs their organizational benefit in a probabilistic-deterministic environment where agents frequently edit these files.
|
||||
- **Mocking Probabilistic Engine:** For verifying *loop mechanics*, mocking LLM responses is essential to ensure test determinism, while integration tests can use live LLM calls.
|
||||
@@ -1,33 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Shell Actuator Security Hardening
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:security:shell:injection:autonomy:
|
||||
|
||||
* Executive Summary
|
||||
During the formal verification of the `org-skill-shell-actuator`, a critical command injection vulnerability was identified and patched. The previous implementation relied on a naive whitelist check that could be bypassed using shell metacharacters.
|
||||
|
||||
* 1. Issue: Command Injection Vulnerability
|
||||
** Symptoms
|
||||
Commands like `ls ; rm -rf /` were potentially executable if the first word (`ls`) was in the whitelist.
|
||||
** Root Cause
|
||||
The `execute-shell-safely` function only checked the first space-delimited word of the command string against the `*allowed-commands*` whitelist. Since `uiop:run-program` executes string-based commands via `/bin/sh -c`, the shell would process the entire string, including injected commands following metacharacters like `;`, `&`, or `|`.
|
||||
** Resolution
|
||||
1. **Metacharacter Blacklist:** Introduced `*shell-metacharacters*` containing dangerous shell symbols (`; & | > < $ \` \ !`).
|
||||
2. **Strict Validation:** Updated `execute-shell-safely` to scan the *entire* command string for these characters before performing the whitelist check.
|
||||
3. **Defense-in-Depth:** Any command containing a metacharacter is now rejected with a "Security Violation" error, even if the primary command is whitelisted.
|
||||
|
||||
* 2. Side-Issue: Missing Package Context
|
||||
** Symptoms
|
||||
`UNDEFINED-FUNCTION EXECUTE-SHELL-SAFELY` during unit tests.
|
||||
** Root Cause
|
||||
`src/shell-logic.lisp` was missing an `(in-package :opencortex)` declaration, causing symbols to be defined in the default `COMMON-LISP-USER` package instead of the harness package.
|
||||
** Resolution
|
||||
Added the `in-package` header to `shell-logic.lisp`.
|
||||
|
||||
* 3. opencortex Mandate Alignment
|
||||
** Invariant Check
|
||||
- *High-Integrity Memory:* The shell actuator is now formally verified with 4 new unit tests covering whitelist enforcement and injection blocking.
|
||||
- *Literate Programming:* Updated `org-skill-shell-actuator.org` Phase A and Build sections to reflect the hardened logic.
|
||||
|
||||
* 4. Permanent Learnings
|
||||
- **Whole-String Validation:** Never assume that whitelisting the "head" of a command string is sufficient when passing that string to a shell.
|
||||
- **Subshell Avoidance:** While the current fix blacklists metacharacters, future iterations should move toward passing command arguments as a Lisp list to `uiop:run-program`, bypassing the shell entirely.
|
||||
@@ -1,48 +0,0 @@
|
||||
#+TITLE: Root Cause Analysis: Consolidation VI - Task Orchestrator Implementation
|
||||
#+DATE: 2026-04-11
|
||||
#+FILETAGS: :rca:orchestrator:consensus:integrity:
|
||||
|
||||
* Executive Summary
|
||||
The implementation of Consolidation VI (Task Orchestrator) aimed to introduce parallel multi-backend consensus, GTD task integrity, and delegation. During the build, a critical dependency failure was identified in the `lisp-validator` module.
|
||||
|
||||
* 1. Issue: Undefined `SAFETY-HARNESS-VALIDATE`
|
||||
** Symptoms
|
||||
Existing `SAFETY-SUITE` tests failed with `#<UNDEFINED-FUNCTION SAFETY-HARNESS-VALIDATE>`.
|
||||
** Root Cause
|
||||
The function `lisp-validator-validate` was exported in `package.lisp` but never actually defined in `lisp-validator.lisp`. Only the internal recursive walker `lisp-validator-ast-walk` existed. This represents a "Hollow Export" bug where the interface was designed but the implementation was truncated or skipped in a previous session.
|
||||
** Resolution
|
||||
Defined `lisp-validator-validate` as a wrapper around `read-from-string` and `lisp-validator-ast-walk`.
|
||||
|
||||
* 2. Design Decision: Deterministic Consensus
|
||||
** Requirement
|
||||
Multi-backend support to reduce hallucinations and increase reliability.
|
||||
** Solution
|
||||
Implemented `bt:make-thread` parallel queries in `ask-probabilistic`.
|
||||
** Trade-off
|
||||
Selected "Majority Rules" over "First-to-Finish".
|
||||
- *Pros:* Higher accuracy, mathematically consistent.
|
||||
- *Cons:* Slower (latency limited by the slowest provider).
|
||||
** Invariant Alignment
|
||||
Aligns with opencortex Mandate 4 (Radical Transparency) and Invariant 2 (Technical Mastery) by ensuring decisions are auditable and consistent across multiple brains.
|
||||
|
||||
* 3. Design Decision: Task Integrity Gate
|
||||
** Requirement
|
||||
Prevent illegal GTD state transitions.
|
||||
** Solution
|
||||
Added `task-integrity-check` in `deterministic.lisp`.
|
||||
** Invariant Alignment
|
||||
Enforces the "High-Integrity Memory" mandate by ensuring the Org-mode AST remains semantically valid according to GTD rules (e.g., no orphaned active tasks).
|
||||
|
||||
* 4. opencortex Mandate Violations during Session (Corrected)
|
||||
** Violations
|
||||
1. Editing without prior commit.
|
||||
2. Direct `.lisp` edits vs Literate Org tangling.
|
||||
3. Multi-function edits per block.
|
||||
** Correction
|
||||
1. Performed a retrospective commit.
|
||||
2. Synchronized `probabilistic-deterministic.org` and `core.org` with source code.
|
||||
3. Refactored the Markdown flight plan into an Org-mode flight plan.
|
||||
|
||||
* 5. Permanent Learnings
|
||||
- *Check Exports:* Always verify that symbols exported in `package.lisp` have a corresponding definition in the literate source.
|
||||
- *Strict opencortex Mode:* Enable a pre-save hook or agent check to ensure all edits are performed within `#+begin_src` blocks in Literate Org files to avoid synchronization debt.
|
||||
253
docs/v0.2.x-REMEDIATION.org
Normal file
253
docs/v0.2.x-REMEDIATION.org
Normal file
@@ -0,0 +1,253 @@
|
||||
#+TITLE: v0.2.x Remediation Plan
|
||||
#+AUTHOR:
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :docs:plan:remediation:
|
||||
|
||||
* Summary
|
||||
|
||||
Features marked DONE in the ROADMAP for v0.1.0 and v0.2.0 but whose implementations
|
||||
are stubs, no-ops, or missing critical functionality. These should have been
|
||||
completed in their respective versions and must be addressed before v0.3.0
|
||||
development proceeds.
|
||||
|
||||
* P0: system-archivist — Proper Distillation and Link Maintenance
|
||||
|
||||
** Claimed status**: =DONE= (v0.1.0: "Scribe + Gardener background workers" + v0.2.0: "31 org files with full literate prose")
|
||||
|
||||
** Actual state**: =archivist-log= is a trivial log wrapper (~10 lines). No knowledge
|
||||
distillation, no broken link detection, no orphaned node flagging.
|
||||
|
||||
** What it should do**:
|
||||
|
||||
*** Scribe (knowledge distillation)
|
||||
1. Read daily Org log files from the Memex =daily/= directory
|
||||
2. Identify new entries (since last processed commit or timestamp)
|
||||
3. Extract conceptual claims, decisions, and atomic facts from prose
|
||||
4. Generate atomic Zettelkasten notes in =notes/= with:
|
||||
- Descriptive snake_case filename (no dates)
|
||||
- =:CREATED:= property from the source log's date
|
||||
- =Source:= backlink to the original daily file and headline
|
||||
- Tags inferred from content and parent file
|
||||
5. Track processed state to avoid re-distilling the same content
|
||||
|
||||
*** Gardener (structural maintenance)
|
||||
1. Scan all Org files in the Memex for broken =[[file:...][...]]= links
|
||||
2. Scan =memory-store= for =memory-object= entries whose =:parent-id= or =:children=
|
||||
references point to deleted objects (orphaned nodes)
|
||||
3. Flag broken links and orphans with =:GARDENER: broken-link= or =:GARDENER: orphan= tags
|
||||
4. Generate a maintenance report as a Org buffer the user can review
|
||||
|
||||
*** Implementation approach
|
||||
- Wire into =system-event-orchestrator= as cron jobs:
|
||||
- Scribe: daily cron (="<%%Y-%%m-%%d %%a +1d>"=, tier =:cognition=)
|
||||
- Gardener: weekly cron (="<%%Y-%%m-%%d %%a +1w>"=, tier =:cognition=)
|
||||
- Use =orchestrator-register-cron= to schedule
|
||||
- Replace the trivial =archivist-log= function with real implementation
|
||||
- Track last-processed state via =memory-store= (:LATEST_PROCESSED_DATETIME property)
|
||||
or git commit hash
|
||||
|
||||
** Dependencies**: =system-event-orchestrator= (cron scheduling), =core-memory= (object store)
|
||||
|
||||
** Verification**: FiveAM test that creates a daily log with known content, runs the
|
||||
Scribe, and asserts that an atomic note was created with correct backlinks.
|
||||
|
||||
* P0: system-self-improve — Surgical Self-Editing and Self-Repair
|
||||
|
||||
** Claimed status**: =DONE= (v0.2.0: "Self-editing (error detection, surgical fix, hot-reload)")
|
||||
|
||||
** Actual state**: =self-improve-edit= does =(declare (ignore old-text new-text))= followed by
|
||||
a log message — no actual text transformation. =self-improve-fix= same pattern.
|
||||
The skill's trigger is =nil= so it never fires.
|
||||
|
||||
** What it should do**:
|
||||
|
||||
*** Self-edit (surgical text replacement)
|
||||
1. Accept (=filepath=, =old-text=, =new-text=) and apply the transformation
|
||||
2. Read the file, locate =old-text= (with exact match verification), replace with =new-text=
|
||||
3. If the target is an Org file with a =#+begin_src lisp= block, tangling the file
|
||||
and reloading the skill after edit
|
||||
4. Create a memory snapshot before editing (rollback safety)
|
||||
5. Verify the edit succeeded (re-read file, confirm =new-text= appears)
|
||||
6. Return success/failure with a diff summary
|
||||
|
||||
*** Self-fix (error diagnosis and repair)
|
||||
1. Accept (=skill-name=, =error-log=) and diagnose the failure
|
||||
2. Parse the error log for: syntax errors (unmatched parens, invalid forms),
|
||||
undefined symbol references, semantic issues (prohibited forms)
|
||||
3. For syntax errors: locate the problematic region, propose a correction
|
||||
using structural Lisp knowledge
|
||||
4. For undefined references: check if the symbol exists in another package,
|
||||
if the skill's =#+DEPENDS_ON:= declaration is missing a dependency
|
||||
5. For semantic issues: identify the prohibited operation and suggest alternatives
|
||||
6. Invoke =self-improve-edit= to apply the fix
|
||||
7. After repair, run the skill's tests if they exist; if tests pass, hot-reload
|
||||
|
||||
*** Implementation approach
|
||||
- Add an actual =:trigger= function that activates on =:ERROR= or =:STUCK= signal types
|
||||
- =self-improve-edit=: use =uiop:read-file-string=, string replacement with
|
||||
=ppcre:regex-replace= or substring operations, write back with =with-open-file=
|
||||
- =self-improve-fix=: add structural analysis in =programming-lisp.lisp= for error parsing
|
||||
- Leverage the REPL skill for verification after repair (call =lisp-eval= on the fixed code block)
|
||||
|
||||
** Dependencies**: =programming-lisp= (lisp-structural-check), =programming-org= (tangling),
|
||||
=core-memory= (snapshot-memory), =core-skills= (jailed reload)
|
||||
|
||||
** Verification**: FiveAM test that creates a file with known content, calls self-improve-edit,
|
||||
and asserts the replacement was applied. Second test with a file containing a
|
||||
deliberate error, calls self-improve-fix, and asserts the error was corrected.
|
||||
|
||||
* P1: system-event-orchestrator — Bootstrap Implementation
|
||||
|
||||
** Claimed status**: v0.3.0 partially DONE ("hook-registry + cron-registry + tier classifier")
|
||||
|
||||
** Actual state**: Hook/cron registries, tier dispatching, and heartbeat integration work.
|
||||
But =orchestrator-bootstrap= is a stub: =(log-message "ORCHESTRATOR: Bootstrap complete")=
|
||||
|
||||
** What it should do**:
|
||||
|
||||
1. Scan the Memex =projects/= and =notes/= directories for Org files containing =#+HOOK:= properties
|
||||
2. For each =#+HOOK:= property found, call =orchestrator-register-hook= with
|
||||
the hook name and a gate function
|
||||
3. For files with =#+CRON:= properties (or cron expressions in timestamps),
|
||||
register them via =orchestrator-register-cron=
|
||||
4. Log the count of registered hooks and cron jobs at completion
|
||||
5. Run bootstrap once at startup (after memory is loaded but before cognitive loop begins)
|
||||
|
||||
*** Implementation approach
|
||||
- Use =uiop:directory-files= with glob patterns for =*.org= files
|
||||
- Use =org-element= from Emacs (via =emacs-bridge= or =org-eval= skill) for parsing,
|
||||
or implement a simple regex-based Org property parser in Lisp
|
||||
- Walk each file's headlines, extract property drawers, filter for =HOOK:= and =CRON:= keys
|
||||
- Call existing =orchestrator-register-hook= / =orchestrator-register-cron=
|
||||
|
||||
** Dependencies**: =programming-org= (Org file parsing), file system access
|
||||
|
||||
** Verification**: Create a test Org file with =#+HOOK: on-write=, run bootstrap,
|
||||
assert the hook registry contains the expected entry.
|
||||
|
||||
* P1: system-memory — Memory Introspection
|
||||
|
||||
** Claimed status**: Skill exists but was never part of a version milestone.
|
||||
|
||||
** Actual state**: =memory-inspect= is a no-op: =(log-message "MEMORY: Self-inspection triggered.")=
|
||||
The =:trigger= is =nil= so the skill never activates.
|
||||
|
||||
** What it should do**:
|
||||
|
||||
1. Return a structured report of memory state:
|
||||
- Total objects in =*memory-store*=
|
||||
- Distribution by type (=:HEADLINE=, =:PARAGRAPH=, etc.)
|
||||
- Distribution by =:TODO-STATE= (=TODO=, =NEXT=, =DONE=, etc.)
|
||||
- Count of privacy-filtered objects
|
||||
- Most recent objects (by =:version= timestamp)
|
||||
- Current snapshot count and timestamps
|
||||
- Orphaned objects (parent-id references a deleted ID)
|
||||
2. Accept an optional filter to narrow the report (by type, by tag, by time range)
|
||||
3. Wire the trigger to activate on =:INTROSPECTION= signal type or =/memory= commands
|
||||
|
||||
*** Implementation approach
|
||||
- Iterate =*memory-store*= with =maphash=, collect statistics
|
||||
- Add to skill trigger: =(eq (getf (getf ctx :payload) :sensor) :introspection)=
|
||||
- Return results as a plist that can be rendered in the TUI
|
||||
|
||||
** Dependencies**: =core-memory= (memory-store and memory-object struct)
|
||||
|
||||
** Verification**: Ingest known objects, call memory-inspect, assert type counts and
|
||||
object counts match.
|
||||
|
||||
* P2: core-context — Semantic Retrieval (Embeddings)
|
||||
|
||||
** Claimed status**: The foveal-peripheral model is implemented and tested, but the
|
||||
embedding pipeline that feeds it is listed as TODO for v0.3.0.
|
||||
|
||||
** Actual state**: The context rendering code (=context-object-render=) computes
|
||||
=cosine-similarity= correctly, but =org-object-vector= is never populated.
|
||||
All objects have =nil= vectors, all similarities are =0.0=, and the model
|
||||
falls back to "include everything within depth 2." This is functionally
|
||||
equivalent to no retrieval at all.
|
||||
|
||||
** What it should do**:
|
||||
|
||||
1. Add a =populate-vector= function to =core-memory= that calls an embedding
|
||||
provider and stores the result in the =memory-object= =:vector= slot
|
||||
2. At ingest time (=ingest-ast=), generate embeddings for new objects
|
||||
3. Embedding provider options (in priority order):
|
||||
- Ollama (local, =nomic-embed-text= or =mxbai-embed-large=)
|
||||
- OpenAI-compatible embedding API (=text-embedding-3-small=)
|
||||
- Fallback: TF-IDF bag-of-words vector (no external dependency)
|
||||
4. Updates: when =memory-object= content changes, mark =:vector= as =:pending=
|
||||
and process in a background batch via the event orchestrator
|
||||
5. Add an environment variable =EMBEDDING_PROVIDER= with default =ollama=
|
||||
|
||||
*** Implementation approach
|
||||
- Add an =:embedding-provider= function stored in =*config*=
|
||||
- =embed-object=: take content string → call provider → store float vector
|
||||
- Modify =ingest-ast= to call =embed-object= on each new object
|
||||
- Add batch processing in =system-event-orchestrator= for vector updates
|
||||
- Use =bordeaux-threads= with a lock for async embedding generation
|
||||
|
||||
** Dependencies**: External embedding provider (Ollama or API), =core-memory= (vector slot)
|
||||
|
||||
** Verification**: Create objects with content, run embedding pipeline, assert vectors
|
||||
are non-nil and have the correct dimensionality. Verify that =cosine-similarity=
|
||||
between semantically similar objects exceeds 0.75 threshold.
|
||||
|
||||
* P2: core-context — Subtree-Based Skill Source Loading
|
||||
|
||||
** Claimed status**: DESIGN_DECISIONS §"Org-Mode as Unified AST" describes: "When the
|
||||
agent needs information about the =openctl-db= function, it queries for the
|
||||
=openctl-db= subtree specifically."
|
||||
|
||||
** Actual state**: =context-skill-source= reads the ENTIRE Org file as a string via
|
||||
=uiop:read-file-string=. No subtree query exists.
|
||||
|
||||
** What it should do**:
|
||||
|
||||
1. Add a =context-skill-subtree= function that takes (=skill-name=, =heading-name=)
|
||||
and returns only the content under that headline
|
||||
2. Add a =context-skill-function-signature= function that returns only the function
|
||||
name, lambda list, and docstring
|
||||
3. Add a =context-skill-tests= function that returns only test blocks
|
||||
4. Modify =context-skill-source= to optionally accept a =:subtree= keyword argument
|
||||
5. If the Org file has an Org-element parser available, use it for structural queries;
|
||||
otherwise fall back to regex-based headline matching
|
||||
|
||||
*** Implementation approach
|
||||
- Use =org-element= via =org-eval= skill (REPL bridge to Emacs) if available
|
||||
- Lisp-native fallback: parse Org headlines with regex (=^*+ = pattern),
|
||||
match heading name by string comparison, extract content until next
|
||||
headline of equal or higher level
|
||||
- Cache parsed results to avoid re-parsing on repeated queries
|
||||
|
||||
** Dependencies**: =programming-org= (Org parsing utilities), =emacs-bridge= (if Emacs
|
||||
Org-element is preferred)
|
||||
|
||||
** Verification**: Create a test Org file with multiple headlines, query for a specific
|
||||
subtree, assert only that subtree's content is returned.
|
||||
|
||||
* Priority and Sequencing
|
||||
|
||||
The remediation should proceed in this order:
|
||||
|
||||
1. **system-event-orchestrator bootstrap** (P1) — needed as infrastructure for Scribe/Gardener cron scheduling
|
||||
2. **system-archivist** (P0) — depends on orchestrator for cron scheduling
|
||||
3. **system-self-improve** (P0) — independent, can proceed in parallel with #2
|
||||
4. **core-context embeddings** (P2) — independent, unlocks semantic retrieval
|
||||
5. **core-context subtree loading** (P2) — independent, improves context efficiency
|
||||
6. **system-memory inspect** (P1) — lowest priority, nice-to-have introspection
|
||||
|
||||
P0 items must be completed before v0.3.0 development begins. P1 items should be
|
||||
completed before v0.3.0 is released. P2 items can extend into early v0.3.0.
|
||||
|
||||
* Out of Scope
|
||||
|
||||
Features listed as TODO in the ROADMAP for v0.3.0+ are NOT in this remediation
|
||||
plan. Specifically excluded:
|
||||
|
||||
- HITL continuation-based suspension (v0.3.0 TODO)
|
||||
- Model-tier routing / cost optimization (v0.3.0 TODO)
|
||||
- Memory scope segmentation (v0.3.0 TODO)
|
||||
- Long-horizon planning / task trees (v0.4.0 TODO)
|
||||
- Shadow simulation mode (not on roadmap, aspirational)
|
||||
- Formal verification of dispatcher rules (not on roadmap, aspirational)
|
||||
- Bouncer rule learning from HITL decisions (not on roadmap, aspirational)
|
||||
@@ -1,16 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(SETF (GETHASH "fake-hash-123" *HISTORY-STORE*)
|
||||
#S(ORG-OBJECT
|
||||
:ID "persist-test-1"
|
||||
:TYPE NIL
|
||||
:ATTRIBUTES NIL
|
||||
:CONTENT "Integrity Check"
|
||||
:VECTOR NIL
|
||||
:PARENT-ID NIL
|
||||
:CHILDREN NIL
|
||||
:VERSION NIL
|
||||
:LAST-SYNC NIL
|
||||
:HASH "fake-hash-123"))
|
||||
(SETF (GETHASH "persist-test-1" *MEMORY*)
|
||||
(GETHASH "fake-hash-123" *HISTORY-STORE*))
|
||||
388
harness/act.org
388
harness/act.org
@@ -1,388 +0,0 @@
|
||||
#+TITLE: Stage 3: Act (act.lisp)
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :harness:act:
|
||||
#+STARTUP: content
|
||||
|
||||
* Stage 3: Act (act.lisp)
|
||||
|
||||
** Architectural Intent: The Last Mile
|
||||
|
||||
The Act stage is where cognition meets reality. After the Probabilistic engine proposes and the Deterministic engine verifies, Act executes the approved action.
|
||||
|
||||
The key insight of the Act stage is that *execution is the point of no return*. Once a command is sent to the shell or a file is written, side effects have occurred. Therefore, Act implements a "last-mile" safety check - even after skills have verified the action, there's a final validation before dispatch.
|
||||
|
||||
** Why Separate Actuators?
|
||||
|
||||
The actuator pattern decouples /what to do/ from /how to do it/:
|
||||
|
||||
- The reasoning engine generates action plists like `(:TYPE :REQUEST :TARGET :SHELL :PAYLOAD ...)`
|
||||
- The actuator interprets the target and executes appropriately
|
||||
- Adding a new actuator (Telegram, Matrix, etc.) doesn't require changing the reasoning code
|
||||
|
||||
This follows the Open/Closed principle: open for extension, closed for modification.
|
||||
|
||||
** The Feedback Loop
|
||||
|
||||
Act is unique in the pipeline because it can generate new signals. When a tool executes and returns data, that data becomes a new signal that feeds back into Perceive → Reason → Act.
|
||||
|
||||
Example feedback chain:
|
||||
1. User asks "What files changed today?"
|
||||
2. Reason generates shell command action
|
||||
3. Act executes shell, gets file list
|
||||
4. Act returns file list as feedback signal
|
||||
5. Reason processes file list, generates human-readable response
|
||||
6. Act displays response
|
||||
|
||||
* Package Context
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
* Actuator Configuration
|
||||
|
||||
** Actuator Registry Variables
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
(defvar *default-actuator* :cli
|
||||
"The actuator used when no explicit target is specified.
|
||||
Override with DEFAULT_ACTUATOR environment variable.")
|
||||
|
||||
(defvar *silent-actuators* '(:cli :system-message :emacs)
|
||||
"List of actuators that don't generate tool-output feedback.
|
||||
These typically have their own feedback mechanisms (CLI prints directly, etc.)")
|
||||
#+end_src
|
||||
|
||||
** initialize-actuators: System Bootstrap
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
(defun initialize-actuators ()
|
||||
"Load actuator configuration from environment and register core actuators.
|
||||
|
||||
Environment variables:
|
||||
- DEFAULT_ACTUATOR: Keyword for default target (:cli, :shell, etc.)
|
||||
- SILENT_ACTUATORS: Comma-separated list of actuators that skip feedback
|
||||
|
||||
Registers three core actuators:
|
||||
1. :system - Internal commands (eval, create-skill, message)
|
||||
2. :tool - Cognitive tool execution
|
||||
3. :tui - Terminal UI output via reply stream"
|
||||
|
||||
;; Load environment configuration
|
||||
(let ((def (uiop:getenv "DEFAULT_ACTUATOR"))
|
||||
(silent (uiop:getenv "SILENT_ACTUATORS")))
|
||||
|
||||
;; Set default actuator
|
||||
(when def
|
||||
(setf *default-actuator*
|
||||
(intern (string-upcase def) "KEYWORD")))
|
||||
|
||||
;; Parse silent actuators list
|
||||
(when silent
|
||||
(setf *silent-actuators*
|
||||
(mapcar (lambda (s)
|
||||
(intern (string-upcase (string-trim '(#\Space) s))
|
||||
"KEYWORD"))
|
||||
(str:split "," silent)))))
|
||||
|
||||
;; Register core harness actuators
|
||||
(register-actuator :system #'execute-system-action)
|
||||
(register-actuator :tool #'execute-tool-action)
|
||||
|
||||
;; TUI actuator: sends response back through the reply stream
|
||||
(register-actuator :tui (lambda (action context)
|
||||
(let* ((meta (getf context :meta))
|
||||
(stream (getf meta :reply-stream)))
|
||||
(when (and stream (open-stream-p stream))
|
||||
(format stream "~a" (frame-message action))
|
||||
(finish-output stream))))))
|
||||
#+end_src
|
||||
|
||||
* Action Dispatching
|
||||
|
||||
** dispatch-action: The Router
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
(defun dispatch-action (action context)
|
||||
"Route an approved action to its registered actuator.
|
||||
|
||||
ACTION is a plist with structure:
|
||||
(:TYPE :REQUEST :TARGET :shell :PAYLOAD (...))
|
||||
|
||||
CONTEXT is the signal being processed (for metadata access)
|
||||
|
||||
The target is resolved in order of priority:
|
||||
1. Explicit :target in the action
|
||||
2. :source from the original signal's metadata
|
||||
3. *default-actuator* configuration variable
|
||||
|
||||
Returns the actuator's result (may be a feedback signal or NIL)."
|
||||
|
||||
(let ((payload (proto-get action :payload)))
|
||||
|
||||
;; Heartbeats don't generate actuation
|
||||
(when (eq (proto-get payload :sensor) :heartbeat)
|
||||
(return-from dispatch-action nil))
|
||||
|
||||
(when (and action (listp action))
|
||||
(let* ((meta (proto-get context :meta))
|
||||
(source (proto-get meta :source))
|
||||
(raw-target (or (ignore-errors (getf action :TARGET))
|
||||
(ignore-errors (getf action :target))
|
||||
source
|
||||
*default-actuator*))
|
||||
(target (intern (string-upcase (string raw-target)) :keyword))
|
||||
(actuator-fn (gethash target *actuator-registry*)))
|
||||
|
||||
;; Preserve metadata in outbound action
|
||||
(when (and meta (null (getf action :meta)))
|
||||
(setf (getf action :meta) meta))
|
||||
|
||||
;; Execute or log error
|
||||
(if actuator-fn
|
||||
(funcall actuator-fn action context)
|
||||
(harness-log "ACT ERROR: No actuator registered for '~s' (requested by ~s)"
|
||||
target raw-target))))))
|
||||
#+end_src
|
||||
|
||||
* Actuator Implementations
|
||||
|
||||
** execute-system-action: Internal Commands
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
(defun execute-system-action (action context)
|
||||
"Execute internal harness commands.
|
||||
|
||||
This actuator handles meta-commands that affect the harness itself,
|
||||
rather than external side effects. Commands include:
|
||||
|
||||
- :eval - Evaluate arbitrary Lisp code (DANGEROUS, validate first!)
|
||||
- :create-skill - Write a new skill org file and reload
|
||||
- :message - Log a message to the harness log
|
||||
|
||||
These commands bypass the normal actuator system since they operate
|
||||
on the harness internals rather than external systems."
|
||||
|
||||
(declare (ignore context))
|
||||
|
||||
(let* ((payload (ignore-errors (getf action :payload)))
|
||||
(cmd (ignore-errors (getf payload :action))))
|
||||
|
||||
(case cmd
|
||||
;; Evaluate Lisp code - guarded by lisp-validator skill
|
||||
(:eval
|
||||
(let ((code (getf payload :code)))
|
||||
(eval (read-from-string code))))
|
||||
|
||||
;; Create and load a new skill from content
|
||||
(:create-skill
|
||||
(let* ((filename (getf payload :filename))
|
||||
(content (getf payload :content))
|
||||
(skills-dir (merge-pathnames "skills/"
|
||||
(asdf:system-source-directory :opencortex)))
|
||||
(full-path (merge-pathnames filename skills-dir)))
|
||||
(with-open-file (out full-path
|
||||
:direction :output
|
||||
:if-exists :supersede)
|
||||
(write-string content out))
|
||||
(load-skill-from-org full-path)))
|
||||
|
||||
;; Log an informational message
|
||||
(:message
|
||||
(harness-log "ACT [System]: ~a" (getf payload :text)))
|
||||
|
||||
;; Unknown command
|
||||
(t
|
||||
(harness-log "ACT ERROR [System]: Unknown command '~s'" cmd)))))
|
||||
#+end_src
|
||||
|
||||
** execute-tool-action: Cognitive Tool Execution
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
(defun execute-tool-action (action context)
|
||||
"Execute a registered cognitive tool.
|
||||
|
||||
Tools are registered functions with:
|
||||
- A guard function (optional, for safety checks)
|
||||
- A body function (the actual implementation)
|
||||
- Metadata (description, parameter specs)
|
||||
|
||||
This actuator:
|
||||
1. Looks up the tool by name
|
||||
2. Runs the guard function (if present)
|
||||
3. Executes the body function with parsed arguments
|
||||
4. Returns a feedback signal with the result
|
||||
|
||||
The feedback mechanism allows tool results to trigger further reasoning."
|
||||
|
||||
(let* ((payload (getf action :payload))
|
||||
(tool-name (getf payload :tool))
|
||||
(tool-args (getf payload :args))
|
||||
(depth (getf context :depth 0))
|
||||
(meta (getf context :meta))
|
||||
(source (getf meta :source))
|
||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
||||
|
||||
(if tool
|
||||
(handler-case
|
||||
;; Parse arguments (handle both flat and nested plists)
|
||||
(let* ((clean-args (if (and (listp tool-args)
|
||||
(listp (car tool-args)))
|
||||
(car tool-args)
|
||||
tool-args))
|
||||
(result (funcall (cognitive-tool-body tool) clean-args)))
|
||||
|
||||
;; Format result for source
|
||||
(when source
|
||||
(dispatch-action (list :TYPE :REQUEST
|
||||
:TARGET source
|
||||
:PAYLOAD (list :ACTION :MESSAGE
|
||||
:TEXT (format-tool-result tool-name result)))
|
||||
context))
|
||||
|
||||
;; Return feedback signal for potential further processing
|
||||
(list :TYPE :EVENT
|
||||
:DEPTH (1+ depth)
|
||||
:META meta
|
||||
:PAYLOAD (list :SENSOR :tool-output
|
||||
:RESULT result
|
||||
:TOOL tool-name)))
|
||||
|
||||
;; Tool execution error
|
||||
(error (c)
|
||||
(list :TYPE :EVENT
|
||||
:DEPTH (1+ depth)
|
||||
:META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error
|
||||
:TOOL tool-name
|
||||
:MESSAGE (format nil "~a" c)))))
|
||||
|
||||
;; Tool not found
|
||||
(list :TYPE :EVENT
|
||||
:DEPTH (1+ depth)
|
||||
:META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error
|
||||
:MESSAGE (format nil "Tool '~a' not found" tool-name)))))
|
||||
#+end_src
|
||||
|
||||
** format-tool-result: Human-Readable Output
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
(defun format-tool-result (tool-name result)
|
||||
"Format a tool result for human-readable display.
|
||||
|
||||
Tools return either:
|
||||
- A plist: (:status :success :content \"...\") or (:status :error :message \"...\")
|
||||
- A raw value (string, number, etc.)
|
||||
|
||||
This function normalizes both formats into a consistent string presentation."
|
||||
|
||||
(if (listp result)
|
||||
(let ((status (getf result :status))
|
||||
(content (getf result :content))
|
||||
(msg (getf result :message)))
|
||||
(cond
|
||||
((and (eq status :success) content)
|
||||
(format nil "~a" content))
|
||||
((and (eq status :error) msg)
|
||||
(format nil "ERROR [~a]: ~a" tool-name msg))
|
||||
(t
|
||||
(format nil "TOOL [~a] RESULT: ~s" tool-name result))))
|
||||
(format nil "TOOL [~a] RESULT: ~a" tool-name result)))
|
||||
#+end_src
|
||||
|
||||
* The Act Gate
|
||||
|
||||
** act-gate: Final Pipeline Stage
|
||||
|
||||
#+begin_src lisp :tangle ../library/act.lisp
|
||||
(defun act-gate (signal)
|
||||
"Final stage of the metabolic pipeline: Actuation.
|
||||
|
||||
This stage has three responsibilities:
|
||||
|
||||
1. Last-mile safety check: Run deterministic gates one more time
|
||||
before execution (handles race conditions, concurrent modifications)
|
||||
|
||||
2. Actuation: Dispatch the approved action to its target actuator
|
||||
|
||||
3. Feedback generation: If the action produced results, create a
|
||||
feedback signal that feeds back into the pipeline
|
||||
|
||||
Modifies the signal:
|
||||
- :approved-action - May be modified by last-mile verification
|
||||
- :status - Set to :acted
|
||||
|
||||
Returns a feedback signal if the action produced results, otherwise NIL."
|
||||
|
||||
(let* ((approved (getf signal :approved-action))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(source (getf meta :source))
|
||||
(feedback nil)
|
||||
(context signal))
|
||||
|
||||
;; Step 1: Last-mile deterministic verification
|
||||
;; This catches any issues that arose between reasoning and acting
|
||||
(when approved
|
||||
(let* ((original-type (getf approved :type))
|
||||
(verified (deterministic-verify approved signal)))
|
||||
|
||||
;; Check if deterministic verification blocked the action
|
||||
(if (and (listp verified)
|
||||
(member (getf verified :type) '(:LOG :EVENT :log :event))
|
||||
(not (member original-type '(:LOG :EVENT :log :event))))
|
||||
|
||||
;; Action was blocked by verification
|
||||
(progn
|
||||
(harness-log "ACT BLOCKED: Action failed last-mile deterministic check.")
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf approved nil)
|
||||
(setf feedback verified))
|
||||
|
||||
;; Action passed verification
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf approved verified)))))
|
||||
|
||||
;; Step 2: Actuation based on signal type
|
||||
(case type
|
||||
;; Explicit requests go directly to dispatch
|
||||
(:REQUEST
|
||||
(dispatch-action signal context))
|
||||
|
||||
;; Log messages also dispatch
|
||||
(:LOG
|
||||
(dispatch-action signal context))
|
||||
|
||||
;; Events with approved actions dispatch to their target
|
||||
(:EVENT
|
||||
(if approved
|
||||
(let* ((target (getf approved :target))
|
||||
(result (dispatch-action approved context)))
|
||||
|
||||
;; Determine feedback based on actuator response
|
||||
(cond
|
||||
;; Actuator returned a signal - use it as feedback
|
||||
((and (listp result)
|
||||
(member (getf result :type) '(:EVENT :LOG)))
|
||||
(setf feedback result))
|
||||
|
||||
;; Non-silent actuator with result - format as tool-output
|
||||
((and result
|
||||
(not (member target *silent-actuators*)))
|
||||
(setf feedback (list :type :EVENT
|
||||
:depth (1+ (getf signal :depth 0))
|
||||
:meta meta
|
||||
:payload (list :sensor :tool-output
|
||||
:result result
|
||||
:tool approved))))))
|
||||
|
||||
;; No approved action, but have source - might be raw event
|
||||
(when source
|
||||
(dispatch-action signal context)))))
|
||||
|
||||
;; Step 3: Update signal status
|
||||
(setf (getf signal :status) :acted)
|
||||
feedback))
|
||||
#+end_src
|
||||
@@ -1,155 +0,0 @@
|
||||
#+TITLE: Communication Protocol (communication.lisp)
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :harness:protocol:
|
||||
#+STARTUP: content
|
||||
|
||||
* Communication Protocol (communication.lisp)
|
||||
** Architectural Intent: Secure Inter-Process Communication & Deterministic Framing
|
||||
|
||||
The ~communication.lisp~ module defines the low-level transport and framing logic for OpenCortex stimuli.
|
||||
|
||||
* Implementation (communication.lisp)
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
"Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp :tangle ../library/communication.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
||||
"Global registry mapping target keywords to their physical actuator functions.")
|
||||
|
||||
(defun register-actuator (name fn)
|
||||
"Registers an actuator function. Actuators receive: (ACTION CONTEXT)."
|
||||
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
||||
(setf (gethash key *actuator-registry*) fn)))
|
||||
|
||||
(defun frame-message (msg-plist)
|
||||
"Frames a Lisp plist with a 6-character hex length and a newline for stream integrity."
|
||||
(let* ((*print-pretty* nil)
|
||||
(*print-circle* nil)
|
||||
(msg-string (format nil "~s" msg-plist))
|
||||
(len (length msg-string)))
|
||||
(format nil "~6,'0x~a~%" len msg-string)))
|
||||
|
||||
(defun read-framed-message (stream)
|
||||
"Reads a hex-length prefixed S-expression from the stream securely. Skips leading whitespace."
|
||||
(let ((length-buffer (make-string 6)))
|
||||
(handler-case
|
||||
(progn
|
||||
;; 1. Skip leading whitespace (newlines, spaces, etc.)
|
||||
(loop for char = (peek-char nil stream nil :eof)
|
||||
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return)))
|
||||
do (read-char stream))
|
||||
|
||||
;; 2. Read the 6-char hex length
|
||||
(let ((count (read-sequence length-buffer stream)))
|
||||
(cond ((< count 6) :eof)
|
||||
(t (let ((len (ignore-errors (parse-integer length-buffer :radix 16))))
|
||||
(if (not len)
|
||||
(progn
|
||||
(harness-log "PROTOCOL ERROR: Invalid header ~s. Attempting resync..." length-buffer)
|
||||
:error)
|
||||
(let ((msg-buffer (make-string len)))
|
||||
(read-sequence msg-buffer stream)
|
||||
(let ((*read-eval* nil)
|
||||
(*print-pretty* nil))
|
||||
(handler-case
|
||||
(let ((msg (read-from-string msg-buffer)))
|
||||
(validate-communication-protocol-schema msg)
|
||||
msg)
|
||||
(error (c)
|
||||
(harness-log "PROTOCOL PARSE ERROR: ~a in ~s" c msg-buffer)
|
||||
:error))))))))))
|
||||
(error (c)
|
||||
(harness-log "PROTOCOL READ ERROR: ~a" c)
|
||||
:error))))
|
||||
|
||||
(defun make-hello-message (version)
|
||||
"Constructs the standard HELLO handshake message."
|
||||
(list :TYPE :EVENT
|
||||
:PAYLOAD (list :ACTION :handshake
|
||||
:VERSION version
|
||||
:CAPABILITIES '(:AUTH :SWANK :ORG-AST))))
|
||||
#+end_src
|
||||
|
||||
** Structural Validation (communication-validator.lisp)
|
||||
The validator ensures that incoming messages adhere to the strict property list schema of the communication protocol.
|
||||
|
||||
#+begin_src lisp :tangle ../library/communication-validator.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Strict structural validation for incoming communication protocol messages."
|
||||
(unless (listp msg)
|
||||
(error "Communication Protocol Schema Error: Message must be a property list (got ~s)" (type-of msg)))
|
||||
|
||||
(let ((type (let ((raw (proto-get msg :type))) (if (keywordp raw) (intern (string-upcase (string raw)) :keyword) raw))))
|
||||
(unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS))
|
||||
(progn (harness-log "REJECTED MSG: ~s" msg) (error "Communication Protocol Schema Error: Invalid message type '~a'" type)))
|
||||
|
||||
(case type
|
||||
(:REQUEST
|
||||
;; Allow missing :target if :source is present in :meta, since reason-gate
|
||||
;; will infer :target from :source downstream. This preserves "equality of
|
||||
;; clients" — gateways need not duplicate routing logic.
|
||||
(let ((target (proto-get msg :target))
|
||||
(source (proto-get (proto-get msg :meta) :source)))
|
||||
(unless (or target source)
|
||||
(error "Communication Protocol Schema Error: REQUEST missing mandatory :target and no :source in :meta to infer it"))
|
||||
(unless (proto-get msg :payload)
|
||||
(error "Communication Protocol Schema Error: REQUEST missing mandatory :payload"))))
|
||||
|
||||
(:EVENT
|
||||
(let ((payload (proto-get msg :payload)))
|
||||
(unless (and payload (listp payload))
|
||||
(error "Communication Protocol Schema Error: EVENT missing or invalid :payload"))
|
||||
(unless (or (proto-get payload :action) (proto-get payload :sensor))
|
||||
(error "Communication Protocol Schema Error: EVENT payload must contain :action or :sensor"))))
|
||||
|
||||
(:RESPONSE
|
||||
(unless (proto-get msg :payload)
|
||||
(error "Communication Protocol Schema Error: RESPONSE missing mandatory :payload"))))
|
||||
|
||||
t))
|
||||
|
||||
(defskill :skill-communication-protocol-validator
|
||||
:priority 95
|
||||
:trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:protocol-received)))
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(validate-communication-protocol-schema action)
|
||||
action))
|
||||
#+end_src
|
||||
|
||||
** Message Framing (communication.lisp)
|
||||
Frames a message with a hex length prefix and ensures all data is serializable.
|
||||
|
||||
#+begin_src lisp :tangle ../library/communication.lisp
|
||||
(defun sanitize-protocol-message (msg)
|
||||
"Recursively strips non-serializable objects from a protocol plist."
|
||||
(if (and msg (listp msg))
|
||||
(let ((clean nil))
|
||||
(loop for (k v) on msg by #'cddr
|
||||
do (unless (member k '(:reply-stream :socket :stream))
|
||||
(push k clean)
|
||||
(push (if (listp v) (sanitize-protocol-message v) v) clean)))
|
||||
(nreverse clean))
|
||||
msg))
|
||||
|
||||
(defun frame-message (msg)
|
||||
"Serializes a message plist and prefixes it with a 6-character hex length."
|
||||
(let* ((sanitized (sanitize-protocol-message msg))
|
||||
(payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized)))
|
||||
(len (length payload)))
|
||||
(format nil "~6,'0x~a" len payload)))
|
||||
#+end_src
|
||||
@@ -1,262 +0,0 @@
|
||||
#+TITLE: Peripheral Vision (context.lisp)
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :harness:context:
|
||||
#+STARTUP: content
|
||||
|
||||
* Peripheral Vision (context.lisp)
|
||||
** Architectural Intent: Context Optimization & The Foveal-Peripheral Hybrid
|
||||
|
||||
A common failure mode for Large Language Models (LLMs) is the "Lost in the Middle" phenomenon, where the model's reasoning accuracy degrades as its context window becomes saturated with irrelevant data. Naive approaches to context management—such as simple character-count truncation or sliding windows—often sever the structural relationships that define an Org-mode Memex.
|
||||
|
||||
The ~opencortex~ harness implements a deterministic, tree-aware solution: the **Foveal-Peripheral Hybrid Model**.
|
||||
|
||||
*** 1. The Foveal Focus (High Resolution)
|
||||
When the harness prepares a prompt for the Probabilistic Engine, it identifies a "Foveal Focus"—typically the specific Org headline or task the user is currently interacting with. This node, along with its immediate children and semantically relevant neighbors, is rendered at "High Resolution," meaning its full body text, properties, and metadata are included in the prompt.
|
||||
|
||||
*** 2. The Peripheral Vision (Low Resolution)
|
||||
To maintain global awareness without bloating the context window, the rest of the Memex is rendered at "Low Resolution." The harness recursively walks the Memory and generates a skeletal outline consisting only of titles and IDs. This gives the LLM a "mental map" of the entire system, allowing it to reference other projects or skills without needing to see their full content until they are explicitly brought into focus.
|
||||
|
||||
*** 3. Deterministic Tree-Walking
|
||||
By leveraging Common Lisp's strengths in recursive tree manipulation, the harness can surgically prune the AST before it ever reaches the LLM. This ensures that the structural hierarchy of the Memex is preserved perfectly, even when the content is compressed.
|
||||
|
||||
** The Context Pipeline
|
||||
#+begin_src mermaid
|
||||
flowchart TD
|
||||
Store[(Memory)] --> Filter[Context Query Filter]
|
||||
Filter --> Identification{Identify Foveal ID}
|
||||
Identification --> Foveal[Render Focus: Full Content]
|
||||
Identification --> Peripheral[Render Outline: Titles Only]
|
||||
Foveal --> Assembly[Assemble Global Awareness String]
|
||||
Peripheral --> Assembly
|
||||
Assembly --> LLM[Probabilistic Engine Proposal]
|
||||
#+end_src
|
||||
|
||||
* Context Assembly (context.lisp)
|
||||
The ~context.lisp~ module provides the deterministic functional layer for querying the Memory and transforming its internal pointers into the precise context strings required for neural reasoning.
|
||||
|
||||
** Package Context
|
||||
We begin by ensuring we are executing within the correct isolated package namespace.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Querying the Store (context-query-store)
|
||||
A generalized filter for the Memory. This function allows skills to perform high-level semantic sweeps of the Memex based on tags, TODO states, or Org element types. It returns a list of ~org-object~ structures.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
(defun context-query-store (&key tag todo-state type)
|
||||
"Filters the Memory based on tags, todo states, or types."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let* ((attrs (org-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t))
|
||||
(when (and type (not (eq (org-object-type obj) type))) (setf match nil))
|
||||
(when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil)))
|
||||
(when (and todo-state (not (equal state todo-state))) (setf match nil))
|
||||
(when match (push obj results))))
|
||||
*memory*)
|
||||
results))
|
||||
#+end_src
|
||||
|
||||
** Active Projects (context-get-active-projects)
|
||||
Identifies headlines tagged with ~project~ that have not yet reached a terminal ~DONE~ state. This provides the primary high-level structure for the agent's global awareness.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
(defun context-get-active-projects ()
|
||||
"Returns headlines tagged as 'project' that are not yet marked DONE."
|
||||
(remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(context-query-store :tag "project" :type :HEADLINE)))
|
||||
#+end_src
|
||||
|
||||
** Completed Tasks (context-get-recent-completed-tasks)
|
||||
Retrieves a list of tasks that have reached the terminal ~DONE~ state. This is useful for providing the agent with historical context or for generating summaries of recent work.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
(defun context-get-recent-completed-tasks ()
|
||||
"Retrieves recently finished tasks from the store."
|
||||
(context-query-store :todo-state "DONE" :type :HEADLINE))
|
||||
#+end_src
|
||||
|
||||
** Capability Discovery (context-list-all-skills)
|
||||
Provides a sorted list of all currently loaded skills. In a "Self-Writing" environment, the agent must be able to discover and understand its own capabilities. This function provides the metadata necessary for the agent to decide which skill to trigger or how to resolve dependencies.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
(defun context-list-all-skills ()
|
||||
"Provides a sorted overview of currently loaded system capabilities."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results))
|
||||
*skills-registry*)
|
||||
(sort results #'> :key (lambda (x) (getf x :priority)))))
|
||||
#+end_src
|
||||
|
||||
** Skill Inspection (context-get-skill-source)
|
||||
Reads the raw literate Org source of a specific skill. This is a foundational capability for an agent expected to eventually "self-write" or perform its own maintenance. By reading the literate source, the agent can understand the *intent* behind a skill's logic before proposing a modification. We use the `SKILLS_DIR` environment variable to locate the source files.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
(defun context-get-skill-source (skill-name)
|
||||
"Reads the raw literate source of a specific skill for inspection."
|
||||
(let* ((filename (format nil "~a.org" skill-name))
|
||||
(skills-dir-str (or (uiop:getenv "SKILLS_DIR") (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))
|
||||
(skills-dir (uiop:ensure-directory-pathname (context-resolve-path skills-dir-str)))
|
||||
(full-path (merge-pathnames filename skills-dir)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
#+end_src
|
||||
|
||||
** Harness Logs (context-get-system-logs)
|
||||
Retrieves the most recent entries from the harness's internal circular log buffer. This allows the Probabilistic Engine to see recent errors or successful dispatches, enabling it to course-correct or explain failures to the user. The log limit is externalized to `CONTEXT_LOG_LIMIT`.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
(defun context-get-system-logs (&optional limit)
|
||||
"Retrieves the most recent lines from the harness's internal log."
|
||||
(let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20)))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(let ((count (min log-limit (length *system-logs*))))
|
||||
(subseq *system-logs* 0 count)))))
|
||||
#+end_src
|
||||
|
||||
** AST to Org Rendering (context-render-to-org)
|
||||
This is the core engine of the Foveal-Peripheral model. It recursively transforms the internal ~org-object~ graph back into an Org-mode string.
|
||||
|
||||
It implements the following deterministic logic:
|
||||
1. **Depth 1 & 2:** Always rendered (High-level mental map).
|
||||
2. **Foveal Node:** Rendered with full body content.
|
||||
3. **Semantic Neighbors:** Rendered with full content if their similarity score exceeds the threshold.
|
||||
4. **Peripheral Nodes:** Rendered as skeletal headlines (titles and IDs only).
|
||||
|
||||
The semantic threshold is externalized to `CONTEXT_SEMANTIC_THRESHOLD`.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
(defun context-render-to-org (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil))
|
||||
"Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model."
|
||||
(let* ((id (org-object-id obj))
|
||||
(is-foveal (equal id foveal-id))
|
||||
(title (or (getf (org-object-attributes obj) :TITLE) "Untitled"))
|
||||
(content (org-object-content obj))
|
||||
(children (org-object-children obj))
|
||||
(stars (make-string depth :initial-element #\*))
|
||||
(obj-vector (org-object-vector obj))
|
||||
(threshold (or semantic-threshold (ignore-errors (read-from-string (uiop:getenv "CONTEXT_SEMANTIC_THRESHOLD"))) 0.75))
|
||||
(similarity (if (and foveal-vector obj-vector (not is-foveal))
|
||||
(cosine-similarity foveal-vector obj-vector)
|
||||
0.0))
|
||||
(is-semantically-relevant (>= similarity threshold))
|
||||
;; We always render depth 1 and 2 (Projects and main tasks).
|
||||
;; We always render the foveal node and its immediate children.
|
||||
;; We render deeper nodes ONLY if they are semantically relevant.
|
||||
(should-render (or (<= depth 2) is-foveal is-semantically-relevant))
|
||||
(output ""))
|
||||
|
||||
(when should-render
|
||||
(setf output (format nil "~a ~a~%:PROPERTIES:~%:ID: ~a~%" stars title id))
|
||||
(when is-semantically-relevant
|
||||
(setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity))))
|
||||
(setf output (concatenate 'string output (format nil ":END:~%")))
|
||||
|
||||
;; Only include full body content if this is the Foveal focus or highly relevant
|
||||
(when (and content (or is-foveal is-semantically-relevant))
|
||||
(setf output (concatenate 'string output content (string #\Newline))))
|
||||
|
||||
;; Recursively render children
|
||||
(dolist (child-id children)
|
||||
(let ((child-obj (lookup-object child-id)))
|
||||
(when child-obj
|
||||
;; If the current node is Foveal, its children should be rendered (depth effectively resets)
|
||||
(let ((next-foveal (if is-foveal child-id foveal-id)))
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org child-obj
|
||||
:depth (1+ depth)
|
||||
:foveal-id next-foveal
|
||||
:semantic-threshold threshold
|
||||
:foveal-vector foveal-vector))))))))
|
||||
output))
|
||||
#+end_src
|
||||
|
||||
** Path Resolution (context-resolve-path)
|
||||
A utility function that expands environment variables (like ~$HOME~ or ~$MEMEX_ROOT~) within path strings. This ensures that the agent can interact with files across different machine configurations without hardcoding absolute paths. This version is more robust, supporting multiple environment variables throughout the string.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
(defun context-resolve-path (path-string)
|
||||
"Expands environment variables and strips literal quotes from a path string."
|
||||
(let ((path (if (stringp path-string)
|
||||
(string-trim '(#\" #\' #\Space) path-string)
|
||||
path-string)))
|
||||
(if (and (stringp path) (search "$" path))
|
||||
(let ((result path))
|
||||
(ppcre:do-register-groups (var-name) ("\\$([A-Za-z0-9_]+)" path)
|
||||
(let ((var-val (uiop:getenv var-name)))
|
||||
(when var-val
|
||||
(setf result (ppcre:regex-replace (format nil "\\$~a" var-name) result var-val)))))
|
||||
result)
|
||||
path)))
|
||||
#+end_src
|
||||
|
||||
** Global Awareness (context-assemble-global-awareness)
|
||||
The primary entry point for context generation. This function identifies active projects and the current user focus (captured during the Perceive stage), then invokes the recursive renderer to assemble the pruned Org-mode skeletal outline sent to the LLM.
|
||||
|
||||
#+begin_src lisp :tangle ../library/context.lisp
|
||||
(defun context-assemble-global-awareness (&optional signal)
|
||||
"Produces a high-level skeletal outline of the current Memory for the LLM."
|
||||
(let* ((foveal-id (or (getf signal :foveal-focus)
|
||||
(ignore-errors (getf (getf signal :payload) :target-id))))
|
||||
(projects (context-get-active-projects))
|
||||
(output "GLOBAL MEMEX AWARENESS (Peripheral Vision):
|
||||
"))
|
||||
(if projects
|
||||
(dolist (project projects)
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org project :foveal-id foveal-id))))
|
||||
(setf output (concatenate 'string output "No active projects found.~%")))
|
||||
output))
|
||||
#+end_src
|
||||
|
||||
* Phase E: Chaos (Verification)
|
||||
Following the Engineering Standards, the peripheral vision extraction and rendering logic must be empirically verified.
|
||||
|
||||
** Test Suite Context
|
||||
#+begin_src lisp :tangle ../tests/peripheral-vision-tests.lisp
|
||||
(defpackage :opencortex-peripheral-vision-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:vision-suite))
|
||||
(in-package :opencortex-peripheral-vision-tests)
|
||||
|
||||
(def-suite vision-suite
|
||||
:description "Verification of Foveal-Peripheral context model.")
|
||||
(in-suite vision-suite)
|
||||
#+end_src
|
||||
|
||||
** Foveal Rendering Test
|
||||
Verify that the foveal target is rendered with content, while siblings are skeletal.
|
||||
|
||||
#+begin_src lisp :tangle ../tests/peripheral-vision-tests.lisp
|
||||
(test test-foveal-rendering
|
||||
"Verify that the foveal target is rendered with content, while siblings are skeletal."
|
||||
(clrhash opencortex::*memory*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS "project")
|
||||
:contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node")
|
||||
:raw-content "FOVEAL CONTENT" :contents nil)
|
||||
(:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node")
|
||||
:raw-content "PERIPHERAL CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
;; Test both foveal focus in signal top-level and in payload (legacy)
|
||||
(let ((output (context-assemble-global-awareness (list :foveal-focus "node-foveal"))))
|
||||
(is (search "FOVEAL CONTENT" output))
|
||||
(is (search "* Peripheral Node" output))
|
||||
(is (not (search "PERIPHERAL CONTENT" output))))))
|
||||
#+end_src
|
||||
|
||||
** Awareness Budget Test
|
||||
Verify that context-assemble-global-awareness handles multiple projects correctly.
|
||||
|
||||
#+begin_src lisp :tangle ../tests/peripheral-vision-tests.lisp
|
||||
(test test-awareness-budget
|
||||
"Verify that context-assemble-global-awareness handles multiple projects."
|
||||
(clrhash opencortex::*memory*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS "project") :contents nil))
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS "project") :contents nil))
|
||||
(let ((output (context-assemble-global-awareness)))
|
||||
(is (search "Project 1" output))
|
||||
(is (search "Project 2" output))))
|
||||
#+end_src
|
||||
287
harness/loop.org
287
harness/loop.org
@@ -1,287 +0,0 @@
|
||||
#+TITLE: The Metabolic Loop (loop.lisp)
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :harness:loop:
|
||||
#+STARTUP: content
|
||||
|
||||
* The Metabolic Loop (loop.lisp)
|
||||
** Architectural Intent
|
||||
|
||||
The Metabolic Loop is the /cranial nerve reflex/ of OpenCortex. While skills provide specialized intelligence, the loop provides the fundamental rhythm of existence: the continuous processing of signals from perception through cognition to action.
|
||||
|
||||
Unlike a simple event loop, the Metabolic Loop implements a sophisticated error recovery model. When the system encounters an error, it distinguishes between:
|
||||
|
||||
1. *Transient errors* (tool failures, network timeouts) - recoverable, no state rollback
|
||||
2. *Critical errors* (undefined functions, malformed data structures) - require memory rollback
|
||||
3. *Recursive loops* (signals generating more signals indefinitely) - depth limit enforcement
|
||||
|
||||
This design ensures the agent remains stable under adverse conditions while preserving the ability to recover from genuine system failures.
|
||||
|
||||
** Why Separate Perceive-Reason-Act?
|
||||
|
||||
The three-stage pipeline mirrors the classical sense-think-act paradigm but with a crucial difference: each stage is a pure function that transforms a signal. This allows:
|
||||
|
||||
- *Perceive* to normalize raw input into a standardized signal format
|
||||
- *Reason* to transform the perceived signal into an approved action (or reject it)
|
||||
- *Act* to execute the approved action and potentially generate a feedback signal
|
||||
|
||||
The feedback loop (Act returning a signal that feeds back into Perceive) enables complex multi-step operations where each action can trigger subsequent reasoning.
|
||||
|
||||
** Thread Safety
|
||||
|
||||
The loop operates in a multi-threaded environment:
|
||||
- The main thread runs the heartbeat and idle loop
|
||||
- Async sensors spawn threads for non-blocking I/O
|
||||
- Interrupt handling requires mutex protection to prevent race conditions
|
||||
|
||||
* Package and Thread-Safe Variables
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *interrupt-flag* nil
|
||||
"Atomic flag set by signal handlers to trigger graceful shutdown.
|
||||
Using a dedicated variable avoids race conditions in interrupt handling.")
|
||||
|
||||
(defvar *interrupt-lock* (bt:make-lock "harness-interrupt-lock")
|
||||
"Mutex protecting *interrupt-flag* access.
|
||||
Locking is required because SBCL's interrupt handlers run in uncertain contexts.")
|
||||
|
||||
(defvar *heartbeat-thread* nil
|
||||
"Handle to the heartbeat thread, allowing explicit termination on shutdown.")
|
||||
#+end_src
|
||||
|
||||
* The Metabolic Pipeline
|
||||
|
||||
** process-signal: The Core Engine
|
||||
|
||||
This function implements the Perceive-Reason-Act pipeline. It processes a signal through all three stages and handles the feedback loop where Actions can generate new signals.
|
||||
|
||||
The depth counter prevents infinite recursion—a signal that generates another signal that generates another, etc. By limiting to depth 10, we ensure the system eventually converges or gracefully terminates.
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
(defun process-signal (signal)
|
||||
"The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act.
|
||||
|
||||
SIGNAL is a property list with the following structure:
|
||||
- :type - :EVENT, :REQUEST, :RESPONSE, etc.
|
||||
- :payload - The actual content (sensor data, approved actions, etc.)
|
||||
- :meta - Metadata including source, session, reply stream
|
||||
- :depth - Recursion depth counter (starts at 0)
|
||||
- :status - Processing status (:perceived, :reasoned, :acted)
|
||||
|
||||
Returns NIL when processing is complete, or a new signal for feedback loop."
|
||||
|
||||
(let ((current-signal signal))
|
||||
(loop while current-signal do
|
||||
|
||||
;; Depth limiting prevents infinite recursion from feedback loops
|
||||
(let ((depth (getf current-signal :depth 0))
|
||||
(meta (getf current-signal :meta)))
|
||||
(when (> depth 10)
|
||||
(harness-log "METABOLISM ERROR: Max recursion depth reached.")
|
||||
(return nil))
|
||||
|
||||
;; Check for graceful shutdown interrupt
|
||||
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
|
||||
(harness-log "METABOLISM: Interrupted by shutdown signal.")
|
||||
(bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* nil))
|
||||
(return nil))
|
||||
|
||||
;; The three-stage pipeline wrapped in error handling
|
||||
(handler-case
|
||||
(progn
|
||||
;; Stage 1: Perceive - normalize sensory input
|
||||
(setf current-signal (perceive-gate current-signal))
|
||||
|
||||
;; Stage 2: Reason - generate and verify action proposals
|
||||
(setf current-signal (reason-gate current-signal))
|
||||
|
||||
;; Stage 3: Act - execute approved actions
|
||||
(let ((feedback (act-gate current-signal)))
|
||||
(if feedback
|
||||
;; Action generated a feedback signal - continue processing
|
||||
(progn
|
||||
;; Preserve metadata from original signal
|
||||
(unless (getf feedback :meta)
|
||||
(setf (getf feedback :meta) meta))
|
||||
(setf current-signal feedback))
|
||||
;; No feedback - pipeline complete
|
||||
(setf current-signal nil))))
|
||||
|
||||
;; Error recovery with differentiated response
|
||||
(error (c)
|
||||
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
|
||||
(harness-log "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
|
||||
|
||||
;; Only rollback memory on critical errors, not transient tool failures
|
||||
;; This prevents losing recent context due to a single bad API call
|
||||
(unless (member sensor '(:loop-error :tool-error :syntax-error))
|
||||
(harness-log "CRITICAL ERROR: Initiating Micro-Rollback.")
|
||||
(rollback-memory 0))
|
||||
|
||||
;; At deep recursion or known error types, terminate gracefully
|
||||
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
|
||||
(setf current-signal nil)
|
||||
;; Otherwise, convert error to a loop-error signal for retry
|
||||
(setf current-signal
|
||||
(list :type :EVENT
|
||||
:depth (1+ depth)
|
||||
:meta meta
|
||||
:payload (list :sensor :loop-error
|
||||
:message (format nil "~a" c)
|
||||
:depth depth)))))))))))
|
||||
#+end_src
|
||||
|
||||
** The Feedback Loop Explained
|
||||
|
||||
The pipeline implements a feedback loop where Act can return a new signal:
|
||||
|
||||
1. User input arrives → Perceive normalizes it
|
||||
2. Reason generates an action → Act executes it
|
||||
3. If the action was a tool call that returned new information → Act returns a feedback signal
|
||||
4. Feedback signal feeds back into step 1 for further reasoning
|
||||
|
||||
This enables multi-step workflows where each action can trigger additional analysis.
|
||||
|
||||
* Heartbeat Mechanism
|
||||
|
||||
The heartbeat thread ensures the agent remains alive even without external input. It drives two critical functions:
|
||||
|
||||
1. **Latent reflection** - the agent can think without external prompting
|
||||
2. **Periodic maintenance** - memory auto-save, orphan detection, etc.
|
||||
|
||||
** Heartbeat Configuration Variables
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
(defvar *auto-save-interval* 300
|
||||
"Interval in seconds between automatic memory saves.
|
||||
Defaults to 300 seconds (5 minutes). Set via MEMORY_AUTO_SAVE_INTERVAL env var.")
|
||||
|
||||
(defvar *heartbeat-save-counter* 0
|
||||
"Tracks heartbeats since last save, used to calculate auto-save timing.")
|
||||
#+end_src
|
||||
|
||||
** start-heartbeat: The Pulsing Heart
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
(defun start-heartbeat ()
|
||||
"Starts the background heartbeat thread.
|
||||
|
||||
The heartbeat runs in a dedicated thread to avoid blocking the main
|
||||
signal processing loop. Each heartbeat:
|
||||
|
||||
1. Injects a :HEARTBEAT signal into the metabolic pipeline
|
||||
2. Checks if memory should be auto-saved (based on interval ratio)
|
||||
|
||||
Configuration via environment:
|
||||
- HEARTBEAT_INTERVAL: Seconds between heartbeats (default: 60)
|
||||
- MEMORY_AUTO_SAVE_INTERVAL: Seconds between auto-saves (default: 300)"
|
||||
|
||||
(let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60))
|
||||
(auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) *auto-save-interval*)))
|
||||
(setf *auto-save-interval* auto-save)
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
|
||||
(setf *heartbeat-thread*
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
;; Wait for interval
|
||||
(sleep interval)
|
||||
|
||||
;; Update counter and check if it's time to save
|
||||
(incf *heartbeat-save-counter*)
|
||||
(when (>= *heartbeat-save-counter* (/ *auto-save-interval* interval))
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
(save-memory-to-disk))
|
||||
|
||||
;; Inject heartbeat signal - this runs through the full pipeline
|
||||
;; allowing the agent to do latent reflection even with no input
|
||||
(inject-stimulus
|
||||
(list :type :EVENT
|
||||
:payload (list :sensor :heartbeat
|
||||
:unix-time (get-universal-time)))))
|
||||
|
||||
:name "opencortex-heartbeat"))))
|
||||
#+end_src
|
||||
|
||||
* Main Entry Point
|
||||
|
||||
** Shutdown Configuration
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
(defvar *shutdown-save-enabled* t
|
||||
"When T, save memory to disk on graceful shutdown.
|
||||
Disable for testing or when memory persistence is handled externally.")
|
||||
#+end_src
|
||||
|
||||
** main: System Bootstrap and Idle Loop
|
||||
|
||||
The main function orchestrates system startup:
|
||||
|
||||
1. Load environment variables from ~/.local/share/opencortex/.env
|
||||
2. Restore memory from previous snapshot (crash recovery)
|
||||
3. Initialize actuators and load all skills
|
||||
4. Start the heartbeat thread
|
||||
5. Register SIGINT handler for graceful Ctrl+C shutdown
|
||||
6. Enter idle loop (sleeping in 1-hour increments)
|
||||
|
||||
#+begin_src lisp :tangle ../library/loop.lisp
|
||||
(defun main ()
|
||||
"Entry point for OpenCortex. Initializes the system and enters idle loop.
|
||||
|
||||
Startup sequence:
|
||||
1. Load environment from ~/.local/share/opencortex/.env
|
||||
2. Restore memory from disk (if snapshot exists)
|
||||
3. Initialize actuators (shell, cli, system)
|
||||
4. Load all skills from SKILLS_DIR
|
||||
5. Start heartbeat thread
|
||||
6. Register SIGINT handler for graceful shutdown
|
||||
7. Enter idle loop (sleeps in DAEMON_SLEEP_INTERVAL chunks)
|
||||
|
||||
The idle loop checks for interrupts and saves memory before exit."
|
||||
|
||||
;; Step 1: Load environment variables from standard location
|
||||
(let* ((home (uiop:getenv "HOME"))
|
||||
(env-file (uiop:merge-pathnames*
|
||||
".local/share/opencortex/.env"
|
||||
(uiop:ensure-directory-pathname home))))
|
||||
(when (uiop:file-exists-p env-file)
|
||||
(cl-dotenv:load-env env-file)))
|
||||
|
||||
;; Step 2: Crash recovery - load memory from previous snapshot
|
||||
(load-memory-from-disk)
|
||||
|
||||
;; Step 3-4: Initialize actuators and load skills
|
||||
(initialize-actuators)
|
||||
(initialize-all-skills)
|
||||
|
||||
;; Step 5: Start the heartbeat
|
||||
(start-heartbeat)
|
||||
|
||||
;; Step 6: Register graceful shutdown handler
|
||||
;; SBCL-specific: catches Ctrl+C (SIGINT) and saves before exit
|
||||
#+sbcl
|
||||
(sb-sys:enable-interrupt sb-unix:sigint
|
||||
(lambda (sig code scp)
|
||||
(declare (ignore sig code scp))
|
||||
(harness-log "SHUTDOWN: SIGINT received. Saving memory...")
|
||||
(when *shutdown-save-enabled*
|
||||
(save-memory-to-disk))
|
||||
(uiop:quit 0)))
|
||||
|
||||
;; Step 7: Idle loop - sleep in chunks, checking for interrupts
|
||||
(let ((sleep-interval (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL")))
|
||||
3600)))
|
||||
(loop
|
||||
;; Check for interrupt before each sleep cycle
|
||||
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
|
||||
(harness-log "SHUTDOWN: Interrupt flag set. Saving memory...")
|
||||
(when *shutdown-save-enabled*
|
||||
(save-memory-to-disk))
|
||||
(return))
|
||||
|
||||
;; Sleep in configured intervals (default: 1 hour)
|
||||
(sleep sleep-interval))))
|
||||
#+end_src
|
||||
@@ -1,229 +0,0 @@
|
||||
#+TITLE: Manifest (opencortex.asd)
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :harness:system:
|
||||
#+STARTUP: content
|
||||
|
||||
* Manifest (opencortex.asd)
|
||||
|
||||
** Architectural Intent: The Thin Harness Philosophy
|
||||
|
||||
The ~opencortex.asd~ file is the physical blueprint of the Lisp Machine. It uses **ASDF** (Another System Definition Facility) to orchestrate compilation and loading of all harness modules.
|
||||
|
||||
The core design principle is *Thin Harness, Fat Skills*:
|
||||
|
||||
- **Harness** = The minimal, unbreakable core (protocol, signal processing, memory)
|
||||
- **Skills** = The intelligence layer (policy, validation, actuation, LLM integration)
|
||||
|
||||
This separation means:
|
||||
- The harness rarely changes (immune system)
|
||||
- Skills can be hot-loaded, modified, and swapped without touching the core
|
||||
- Bugs in skills don't crash the system
|
||||
|
||||
** Why ASDF?**
|
||||
|
||||
ASDF is the de facto standard for Common Lisp project management. It:
|
||||
1. Handles dependency resolution and loading order
|
||||
2. Compiles files in the right order (preventing "undefined function" errors)
|
||||
3. Supports system building for deployment
|
||||
4. Integrates with Quicklisp for dependency management
|
||||
|
||||
* The Build Pipeline
|
||||
|
||||
#+begin_src mermaid
|
||||
flowchart TD
|
||||
Org[Literate Org Files] -- Org-Babel Tangle --> Lisp[Source .lisp Files]
|
||||
Lisp --> ASDF[ASDF Manifest: opencortex.asd]
|
||||
ASDF --> Loader[SBCL Compiler / Loader]
|
||||
Loader --> Image[Live Harness Image]
|
||||
Image -- Build --> Binary[Standalone Binary]
|
||||
|
||||
subgraph Skills["Skills Layer (Dynamic)"]
|
||||
S1[Policy Skill]
|
||||
S2[Bouncer Skill]
|
||||
S3[LLM Gateway]
|
||||
S4[...other skills]
|
||||
end
|
||||
|
||||
Image --> Skills
|
||||
#+end_src
|
||||
|
||||
* Design Decisions
|
||||
|
||||
** Strict Serial Loading
|
||||
|
||||
The harness uses ~:serial t~ in the ASDF definition. This means:
|
||||
|
||||
1. Files are loaded in order: package → skills → communication → memory → context → perceive → reason → act → loop
|
||||
2. ~package.lisp~ is always loaded before any code that uses its symbols
|
||||
3. ~skills.lisp~ (defining macros like ~defskill~, ~def-cognitive-tool~) loads before skills
|
||||
|
||||
This eliminates "macro not found" errors that plague non-linear loading systems.
|
||||
|
||||
** Why Not Module Dependencies?**
|
||||
|
||||
Traditional ASDF uses ~:depends-on~ to declare dependencies. We use ~:serial t~ because:
|
||||
|
||||
1. *Explicit is better than implicit* - the loading order is visible in one place
|
||||
2. *Prevents circular dependencies* - skills are loaded after the harness, never before
|
||||
3. *Simpler debugging* - when something fails, the loading order is always clear
|
||||
|
||||
** Isolation of Tests
|
||||
|
||||
The testing system (~:opencortex/tests~) is separate from the production system (~:opencortex~). This means:
|
||||
|
||||
- Production deployments don't load FiveAM (saves memory, reduces attack surface)
|
||||
- Tests can be run independently: ~(ql:quickload :opencortex/tests)~
|
||||
- Test data doesn't pollute the production image
|
||||
|
||||
* System Definitions
|
||||
|
||||
** Main Harness System
|
||||
|
||||
#+begin_src lisp :tangle ../opencortex.asd
|
||||
(defsystem :opencortex
|
||||
:name "opencortex"
|
||||
:author "Amr"
|
||||
:version "0.1.0"
|
||||
:license "AGPLv3"
|
||||
:description "The Probabilistic-Deterministic Lisp Machine Harness"
|
||||
|
||||
:depends-on (:usocket ; TCP socket networking
|
||||
:bordeaux-threads ; Threading (heartbeat, async sensors)
|
||||
:dexador ; HTTP client (LLM APIs)
|
||||
:uiop ; Portable I/O, file operations
|
||||
:cl-dotenv ; Environment variable loading
|
||||
:cl-ppcre ; Regular expressions (parsing)
|
||||
:hunchentoot ; HTTP server (optional web interface)
|
||||
:ironclad ; Cryptography (Merkle hashing)
|
||||
:str ; String utilities
|
||||
:cl-json ; JSON parsing/serialization
|
||||
:uuid) ; UUID generation for org-mode IDs
|
||||
|
||||
:serial t ; Load files in order listed below
|
||||
|
||||
:components ((:file "library/package") ; Package definitions, core vars
|
||||
(:file "library/skills") ; Skill engine, cognitive tools
|
||||
(:file "library/communication") ; Protocol, framing, validation
|
||||
(:file "library/memory") ; Org-object store, snapshots
|
||||
(:file "library/context") ; Context assembly, query
|
||||
(:file "library/perceive") ; Stage 1: Sensory normalization
|
||||
(:file "library/reason") ; Stage 2: Neural + deterministic
|
||||
(:file "library/act") ; Stage 3: Actuation
|
||||
(:file "library/loop")) ; Main entry, heartbeat
|
||||
|
||||
:build-operation "program-op"
|
||||
:build-pathname "opencortex-server"
|
||||
:entry-point "opencortex:main")
|
||||
#+end_src
|
||||
|
||||
** Test System
|
||||
|
||||
#+begin_src lisp :tangle ../opencortex.asd
|
||||
(defsystem :opencortex/tests
|
||||
:depends-on (:opencortex ; The harness we're testing
|
||||
:fiveam) ; Testing framework
|
||||
|
||||
:components ((:file "tests/communication-tests")
|
||||
(:file "tests/pipeline-tests")
|
||||
(:file "tests/act-tests")
|
||||
(:file "tests/boot-sequence-tests")
|
||||
(:file "tests/memory-tests")
|
||||
(:file "tests/immune-system-tests"))
|
||||
|
||||
:perform (test-op (o s)
|
||||
(uiop:symbol-call :fiveam :run! :communication-protocol-suite)
|
||||
(uiop:symbol-call :fiveam :run! :pipeline-suite)
|
||||
(uiop:symbol-call :fiveam :run! :safety-suite)
|
||||
(uiop:symbol-call :fiveam :run! :boot-suite)
|
||||
(uiop:symbol-call :fiveam :run! :memory-suite)
|
||||
(uiop:symbol-call :fiveam :run! :immune-suite)))
|
||||
#+end_src
|
||||
|
||||
** TUI Client System
|
||||
|
||||
#+begin_src lisp :tangle ../opencortex.asd
|
||||
(defsystem :opencortex/tui
|
||||
:depends-on (:opencortex ; The daemon we're connecting to
|
||||
:croatoan ; Terminal UI library
|
||||
:usocket ; Socket communication
|
||||
:bordeaux-threads) ; Background listening thread
|
||||
|
||||
:components ((:file "library/tui-client")))
|
||||
#+end_src
|
||||
|
||||
* The Harness Boundary Contract
|
||||
|
||||
** Why a Boundary Contract?
|
||||
|
||||
The harness is the immune system of OpenCortex. If it grows fat (accumulating features, dependencies, complexity), it becomes harder to:
|
||||
- Verify for security
|
||||
- Debug when things go wrong
|
||||
- Maintain across versions
|
||||
|
||||
The Boundary Contract defines what IS the harness vs. what belongs in skills.
|
||||
|
||||
** Primary Boundary Files
|
||||
|
||||
| File | Purpose | Modification |
|
||||
|------|---------|--------------|
|
||||
| ~harness/*.org~ | Literate source of truth | Only via Org edits + tangle |
|
||||
| ~opencortex.asd~ | System manifest | Only via Org edits + tangle |
|
||||
| ~library/*.lisp~ | Tangled from .org | NEVER edit directly |
|
||||
|
||||
** Generated Artifacts (NOT Primary)
|
||||
|
||||
The ~library/*.lisp~ files are tangles from the ~harness/*.org~ files. They are derivative artifacts. Direct modification violates the Literate Granularity standard.
|
||||
|
||||
** Protected Paths
|
||||
|
||||
The Policy skill guards these paths by default:
|
||||
|
||||
#+begin_src lisp
|
||||
(defvar *modularity-protected-paths*
|
||||
'("harness/"
|
||||
"opencortex.asd"
|
||||
"library/package.lisp"
|
||||
"library/communication.lisp"
|
||||
"library/memory.lisp"
|
||||
"library/context.lisp"
|
||||
"library/perceive.lisp"
|
||||
"library/reason.lisp"
|
||||
"library/act.lisp"
|
||||
"library/loop.lisp"))
|
||||
#+end_src
|
||||
|
||||
Any agent action proposing to modify these files must include a ~:modularity-justification~ field explaining why the change cannot be implemented as a skill.
|
||||
|
||||
** Enforcement Chain
|
||||
|
||||
1. *Policy Skill* (priority 500) - Checks for missing justifications
|
||||
2. *Bouncer Skill* (priority 100) - Intercepts unauthorized modifications
|
||||
3. *Git Hooks* (optional) - Prevents direct .lisp commits
|
||||
|
||||
* Quick Reference
|
||||
|
||||
** Building the System
|
||||
|
||||
#+begin_src bash
|
||||
# Development: Load source
|
||||
(ql:quickload :opencortex)
|
||||
|
||||
# Build standalone binary
|
||||
(asdf:make :opencortex)
|
||||
|
||||
# Run tests
|
||||
(ql:quickload :opencortex/tests)
|
||||
(asdf:test-system :opencortex/tests)
|
||||
#+end_src
|
||||
|
||||
** Loading Order
|
||||
|
||||
1. ~library/package.lisp~ - Creates ~:opencortex~ package
|
||||
2. ~library/skills.lisp~ - Defines ~defskill~, ~def-cognitive-tool~ macros
|
||||
3. ~library/communication.lisp~ - Protocol, framing, validation
|
||||
4. ~library/memory.lisp~ - Org-object, Merkle tree, snapshots
|
||||
5. ~library/context.lisp~ - Context assembly functions
|
||||
6. ~library/perceive.lisp~ - Stage 1: Perceive gate
|
||||
7. ~library/reason.lisp~ - Stage 2: Reason (think + verify)
|
||||
8. ~library/act.lisp~ - Stage 3: Act (dispatch + execute)
|
||||
9. ~library/loop.lisp~ - Main entry point, heartbeat
|
||||
@@ -1,344 +0,0 @@
|
||||
#+TITLE: The System Memory (memory.lisp)
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :harness:memory:
|
||||
#+STARTUP: content
|
||||
|
||||
* The System Memory (memory.lisp)
|
||||
** Architectural Intent: The Single Address Space (Live Memory)
|
||||
|
||||
Yes, the Memory module is the cognitive bedrock of the opencortex. It is not a database; it is the agent's live, active "brain" state.
|
||||
|
||||
Traditional architectures rely on external databases (SQLite, Vector DBs) which introduce I/O latency and structural impedance. The opencortex architecture chooses a different path: the **Single Address Space**. By treating the entire knowledge base as a graph of Lisp pointers, we achieve microsecond recollection and total structural transparency.
|
||||
|
||||
- **Pointer-Based Reasoning:** By loading the entire knowledge graph into a live Common Lisp hash table, we achieve microsecond recollection. The harness doesn't "search a file"; it traverses a memory pointer.
|
||||
- **Memory Imaging:** The ability to snapshot the Lisp image allows the agent to resume its entire cognitive state instantly, solving the "Cold Start" problem.
|
||||
- **Merkle-Tree Integrity:** Every node in the Memory is cryptographically hashed. By recursively hashing content and children, the root hash provides a single, immutable fingerprint of the entire system state.
|
||||
|
||||
** System Architecture
|
||||
#+begin_src mermaid
|
||||
flowchart TD
|
||||
subgraph LispMachine[Lisp Machine]
|
||||
H[Harness Pipeline] --> OS[(Memory)]
|
||||
S1[Skill: Architect] --> OS
|
||||
S2[Skill: Analyst] --> OS
|
||||
S3[Skill: GTD] --> OS
|
||||
H -- Pointers --> S1
|
||||
H -- Pointers --> S2
|
||||
end
|
||||
subgraph IPCSlow[External Layer]
|
||||
E[Emacs / Actuators] -. communication protocol .-> H
|
||||
end
|
||||
#+end_src
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** The Object Repository
|
||||
The `*memory*` is the global hash table that holds every Org element by its unique ID. This is the "live RAM" of the agent's memory.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
(defvar *memory* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *history-store* (make-hash-table :test 'equal)
|
||||
"Immutable Merkle-Tree versioning store mapping hashes to objects.")
|
||||
#+end_src
|
||||
|
||||
** The Data Structure (org-object)
|
||||
Every element in the Memex (headlines, paragraphs, etc.) is represented by an `org-object` structure. It contains both semantic metadata (attributes, content) and structural metadata (parent/child pointers, Merkle hashes).
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
(defstruct org-object
|
||||
id type attributes content vector parent-id children version last-sync hash)
|
||||
|
||||
;; Enable serialization via make-load-form (standard CL)
|
||||
(defmethod make-load-form ((obj org-object) &optional env)
|
||||
(make-load-form-saving-slots obj :environment env))
|
||||
#+end_src
|
||||
|
||||
** Merkle Tree Integrity (compute-merkle-hash)
|
||||
The `compute-merkle-hash` function ensures the cryptographic integrity of the knowledge graph. A node's hash depends on its own properties and the hashes of all its children. This creates a recursive fingerprint where any change to a single note propagates up to the root hash.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
(defun compute-merkle-hash (id type attributes content child-hashes)
|
||||
"Computes a SHA-256 Merkle hash for a node based on its core properties and children's hashes."
|
||||
(let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v)))
|
||||
(sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x)))))
|
||||
(attr-string (format nil "~s" sorted-alist))
|
||||
(children-string (format nil "~{~a~}" child-hashes))
|
||||
(data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a"
|
||||
id type attr-string (or content "") children-string))
|
||||
(digester (ironclad:make-digest :sha256)))
|
||||
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string))
|
||||
(ironclad:byte-array-to-hex-string (ironclad:produce-digest digester))))
|
||||
#+end_src
|
||||
|
||||
** Ingesting the AST (ingest-ast)
|
||||
The `ingest-ast` function is the primary bridge between the external world (Emacs/JSON) and the internal Lisp machine. It recursively parses an Org-mode Abstract Syntax Tree (AST) into `org-object` structures and registers them in the store.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
(defun ingest-ast (ast &optional parent-id)
|
||||
"Parses an Org AST into the recursive Lisp Memory with Merkle hashing."
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (or (getf props :ID) (format nil "temp-~a" (get-universal-time))))
|
||||
(contents (getf ast :contents))
|
||||
(raw-content (when (eq type :HEADLINE)
|
||||
(format nil "~a~%~a" (getf props :TITLE) (or (cl:getf ast :raw-content) ""))))
|
||||
(should-embed (and raw-content (equal (getf props :EMBED) "t")))
|
||||
(child-ids nil)
|
||||
(child-hashes nil))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(let ((child-id (ingest-ast child id)))
|
||||
(push child-id child-ids)
|
||||
(let ((child-id-val child-id))
|
||||
(let ((child-obj (lookup-object child-id-val)))
|
||||
(when child-obj (push (org-object-hash child-obj) child-hashes)))))))
|
||||
(setf child-ids (nreverse child-ids))
|
||||
(setf child-hashes (nreverse child-hashes))
|
||||
(let* ((hash (compute-merkle-hash id type props raw-content child-hashes))
|
||||
(existing-obj (gethash hash *history-store*))
|
||||
(obj (or existing-obj
|
||||
(make-org-object
|
||||
:id id :type type :attributes props :content raw-content
|
||||
:vector (when should-embed (get-embedding raw-content))
|
||||
:parent-id parent-id :children child-ids
|
||||
:version (get-universal-time) :last-sync (get-universal-time)
|
||||
:hash hash))))
|
||||
(unless existing-obj
|
||||
(setf (gethash hash *history-store*) obj))
|
||||
(setf (gethash id *memory*) obj)
|
||||
id)))
|
||||
#+end_src
|
||||
|
||||
** Memory Snapshots (snapshot-memory)
|
||||
Because objects are stored immutably in the `*history-store*`, a snapshot is a lightweight shallow copy of the active `*memory*` pointers. The system maintains a rolling buffer of 20 snapshots, allowing for near-instant, zero-cost rollback.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
(defvar *object-store-snapshots* nil)
|
||||
|
||||
(defun copy-hash-table (hash-table)
|
||||
"Creates a shallow copy of a hash table."
|
||||
(let ((new-table (make-hash-table :test (hash-table-test hash-table)
|
||||
:size (hash-table-size hash-table))))
|
||||
(maphash (lambda (k v) (setf (gethash k new-table) v)) hash-table)
|
||||
new-table))
|
||||
|
||||
(defun snapshot-memory ()
|
||||
"Creates a lightweight, Copy-on-Write snapshot using Merkle-Tree pointers."
|
||||
(let ((snapshot (copy-hash-table *memory*)))
|
||||
(push (list :timestamp (get-universal-time) :data snapshot) *object-store-snapshots*)
|
||||
(when (> (length *object-store-snapshots*) 20)
|
||||
(setf *object-store-snapshots* (subseq *object-store-snapshots* 0 20)))
|
||||
(harness-log "MEMORY - CoW Memory snapshot created.")))
|
||||
#+end_src
|
||||
|
||||
** Memory Rollback (rollback-memory)
|
||||
Restores the state of the Memex from one of the previous snapshots.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
(defun rollback-memory (&optional (index 0))
|
||||
"Restores the Memory to a previously captured snapshot using immutable history pointers."
|
||||
(let ((snapshot (nth index *object-store-snapshots*)))
|
||||
(if snapshot
|
||||
(progn (setf *memory* (copy-hash-table (getf snapshot :data)))
|
||||
(harness-log "MEMORY - Memory rolled back to snapshot ~a" index))
|
||||
(harness-log "MEMORY ERROR - Snapshot ~a not found." index))))
|
||||
#+end_src
|
||||
|
||||
** Disk Persistence (save-memory / load-memory)
|
||||
Essential for surviving crashes. Saves the in-memory hash tables to disk and loads them back on restart. The path is controlled by the `MEMORY_SNAPSHOT_PATH` environment variable.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
(defvar *memory-snapshot-path* nil
|
||||
"Path to the memory snapshot file. Set from MEMORY_SNAPSHOT_PATH env or default.")
|
||||
|
||||
(defun ensure-memory-snapshot-path ()
|
||||
"Initializes the snapshot path from environment or default location."
|
||||
(or *memory-snapshot-path*
|
||||
(let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH")))
|
||||
(setf *memory-snapshot-path*
|
||||
(or env-path
|
||||
(uiop:merge-pathnames* "memory.snap" (user-homedir-pathname)))))))
|
||||
|
||||
(defun save-memory-to-disk ()
|
||||
"Serializes *memory* and *history-store* to disk for crash recovery.
|
||||
Converts hash tables to alists for proper serialization."
|
||||
(let ((path (ensure-memory-snapshot-path)))
|
||||
(with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(format stream ";; OpenCortex Memory Snapshot~%")
|
||||
(format stream ";; Created: ~a~%~%" (format nil "~a" (get-universal-time)))
|
||||
(let ((memory-alist nil)
|
||||
(history-alist nil))
|
||||
(maphash (lambda (k v) (push (cons k v) memory-alist)) *memory*)
|
||||
(maphash (lambda (k v) (push (cons k v) history-alist)) *history-store*)
|
||||
(prin1 (list :memory memory-alist :history-store history-alist) stream)))
|
||||
(harness-log "MEMORY - Saved to ~a" path)
|
||||
path))
|
||||
|
||||
(defun load-memory-from-disk ()
|
||||
"Loads *memory* and *history-store* from disk if the snapshot exists.
|
||||
Reconstitutes alists into hash tables."
|
||||
(let ((path (ensure-memory-snapshot-path)))
|
||||
(when (uiop:file-exists-p path)
|
||||
(handler-case
|
||||
(with-open-file (stream path :direction :input)
|
||||
(let ((data (read stream nil)))
|
||||
(when data
|
||||
(let ((memory-alist (getf data :memory))
|
||||
(history-alist (getf data :history-store)))
|
||||
(setf *memory* (make-hash-table :test 'equal :size (length memory-alist)))
|
||||
(dolist (kv memory-alist)
|
||||
(setf (gethash (car kv) *memory*) (cdr kv)))
|
||||
(setf *history-store* (make-hash-table :test 'equal :size (length history-alist)))
|
||||
(dolist (kv history-alist)
|
||||
(setf (gethash (car kv) *history-store*) (cdr kv)))
|
||||
(harness-log "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory*))))))
|
||||
(error (c)
|
||||
(harness-log "MEMORY WARNING - Failed to load snapshot: ~a" c))))
|
||||
t))
|
||||
#+end_src
|
||||
|
||||
** Lookup Utilities
|
||||
Basic functions for retrieving objects by ID or type.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
(defun org-id-new ()
|
||||
"Generates a new UUID string for Org-mode identification."
|
||||
(string-downcase (format nil "~a" (uuid:make-v4-uuid))))
|
||||
|
||||
(defun lookup-object (id)
|
||||
"Retrieves an object from the store by its unique ID."
|
||||
(gethash id *memory*))
|
||||
|
||||
(defun list-objects-by-type (type)
|
||||
"Returns a list of all objects matching a specific Org element type."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj) (declare (ignore id)) (when (eq (org-object-type obj) type) (push obj results))) *memory*)
|
||||
results))
|
||||
(defun list-objects-with-attribute (attr-name value)
|
||||
"Returns a list of all objects where ATTR-NAME matches VALUE."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let ((attrs (org-object-attributes obj)))
|
||||
(when (equal (getf attrs attr-name) value)
|
||||
(push obj results))))
|
||||
*memory*)
|
||||
results))
|
||||
#+end_src
|
||||
|
||||
** Structural Helpers
|
||||
Utility functions for AST traversal and path resolution.
|
||||
|
||||
#+begin_src lisp :tangle ../library/memory.lisp
|
||||
(defun find-headline-missing-id (ast)
|
||||
"Traverses an AST to find headlines that lack an :ID: property."
|
||||
(when (listp ast)
|
||||
(if (and (eq (getf ast :type) :HEADLINE) (not (getf (getf ast :properties) :ID)))
|
||||
ast
|
||||
(cl:some #'find-headline-missing-id (getf ast :contents)))))
|
||||
|
||||
(defun file-name-nondirectory (path)
|
||||
"Extracts the filename from a full path string."
|
||||
(let ((pos (position #\/ path :from-end t))) (if pos (subseq path (1+ pos)) path)))
|
||||
#+end_src
|
||||
|
||||
* Phase E: Chaos (Verification)
|
||||
Following the Engineering Standards, the Memory must be empirically verified through automated testing. The following test suite ensures the mathematical integrity of the Merkle hashes and the behavioral correctness of the immutable versioning and rollback systems.
|
||||
|
||||
#+begin_src lisp :tangle ../tests/memory-tests.lisp
|
||||
(defpackage :opencortex-memory-tests
|
||||
(:use :cl :fiveam :opencortex)
|
||||
(:export #:memory-suite))
|
||||
|
||||
(in-package :opencortex-memory-tests)
|
||||
|
||||
(def-suite memory-suite
|
||||
:description "Tests for the Merkle-Tree Memory.")
|
||||
|
||||
(in-suite memory-suite)
|
||||
|
||||
(test merkle-hash-consistency
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil))
|
||||
(ast2 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
|
||||
(clrhash *memory*)
|
||||
(let ((id1 (ingest-ast ast1)))
|
||||
(let ((hash1 (org-object-hash (lookup-object id1))))
|
||||
(clrhash *memory*)
|
||||
(let ((id2 (ingest-ast ast2)))
|
||||
(let ((hash2 (org-object-hash (lookup-object id2))))
|
||||
(is (equal hash1 hash2))))))))
|
||||
|
||||
(test merkle-hash-cascading
|
||||
(let* ((ast-leaf '(:type :HEADLINE :properties (:ID "leaf" :TITLE "Leaf") :contents nil))
|
||||
(ast-root-full '(:type :HEADLINE :properties (:ID "root" :TITLE "Root")
|
||||
:contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Leaf") :contents nil))))
|
||||
(id-root (progn (clrhash *memory*) (ingest-ast ast-root-full)))
|
||||
(initial-root-hash (org-object-hash (lookup-object id-root))))
|
||||
|
||||
;; Now ingest a modified version (title change)
|
||||
(let* ((ast-root-modified '(:type :HEADLINE :properties (:ID "root" :TITLE "Root")
|
||||
:contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Leaf Modified") :contents nil))))
|
||||
(id-root-mod (progn (clrhash *memory*) (ingest-ast ast-root-modified)))
|
||||
(modified-root-hash (org-object-hash (lookup-object id-root-mod))))
|
||||
(is (not (equal initial-root-hash modified-root-hash))))))
|
||||
|
||||
(test history-store-immutability
|
||||
"Verify that *history-store* retains old versions even after *memory* updates."
|
||||
(clrhash *memory*)
|
||||
(clrhash *history-store*)
|
||||
(let* ((ast-v1 '(:type :HEADLINE :properties (:ID "test-node" :TITLE "Version 1") :contents nil))
|
||||
(id-v1 (ingest-ast ast-v1))
|
||||
(obj-v1 (lookup-object id-v1))
|
||||
(hash-v1 (org-object-hash obj-v1)))
|
||||
|
||||
(let* ((ast-v2 '(:type :HEADLINE :properties (:ID "test-node" :TITLE "Version 2") :contents nil))
|
||||
(id-v2 (ingest-ast ast-v2))
|
||||
(obj-v2 (lookup-object id-v2))
|
||||
(hash-v2 (org-object-hash obj-v2)))
|
||||
|
||||
;; The active pointer should be v2
|
||||
(is (equal (org-object-hash (lookup-object "test-node")) hash-v2))
|
||||
|
||||
;; Both v1 and v2 should exist in the immutable history store
|
||||
(is (not (null (gethash hash-v1 *history-store*))))
|
||||
(is (not (null (gethash hash-v2 *history-store*))))
|
||||
|
||||
;; Modifying v2 should not affect v1 in the history store
|
||||
(is (equal (org-object-content (gethash hash-v1 *history-store*)) "Version 1
|
||||
"))
|
||||
(is (equal (org-object-content (gethash hash-v2 *history-store*)) "Version 2
|
||||
")))))
|
||||
|
||||
(test cow-snapshot-and-rollback
|
||||
"Verify that lightweight snapshots can accurately restore previous pointer states."
|
||||
(clrhash *memory*)
|
||||
(clrhash *history-store*)
|
||||
(setf *object-store-snapshots* nil)
|
||||
|
||||
(let* ((ast-v1 '(:type :HEADLINE :properties (:ID "cow-node" :TITLE "State A") :contents nil))
|
||||
(id-v1 (ingest-ast ast-v1))
|
||||
(hash-v1 (org-object-hash (lookup-object id-v1))))
|
||||
|
||||
;; Take a snapshot at State A
|
||||
(snapshot-memory)
|
||||
|
||||
(let* ((ast-v2 '(:type :HEADLINE :properties (:ID "cow-node" :TITLE "State B") :contents nil))
|
||||
(id-v2 (ingest-ast ast-v2))
|
||||
(hash-v2 (org-object-hash (lookup-object id-v2))))
|
||||
|
||||
;; Verify we are currently in State B
|
||||
(is (equal (org-object-hash (lookup-object "cow-node")) hash-v2))
|
||||
|
||||
;; Rollback to State A (index 0 because we only took 1 snapshot)
|
||||
(rollback-memory 0)
|
||||
|
||||
;; Verify we are back in State A
|
||||
(is (equal (org-object-hash (lookup-object "cow-node")) hash-v1))
|
||||
|
||||
;; Verify State B is still safely in the history store (no data loss)
|
||||
(is (not (null (gethash hash-v2 *history-store*)))))))
|
||||
#+end_src
|
||||
@@ -1,246 +0,0 @@
|
||||
#+TITLE: System Interface (package.lisp)
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :harness:interface:
|
||||
#+STARTUP: content
|
||||
|
||||
* System Interface (package.lisp)
|
||||
The ~package.lisp~ file defines the public API of the ~opencortex~ harness. It serves as the primary membrane between the deterministic core modules and the dynamic world of skills and actuators.
|
||||
|
||||
** Architectural Intent: The Package Membrane
|
||||
By strictly defining the public interface, we ensure that skills remain decoupled from the harness implementation details. This allows for autonomous replacement of any component (e.g., swapping the Memory or the Probabilistic Engine) without breaking existing skills.
|
||||
|
||||
#+begin_src mermaid
|
||||
flowchart TD
|
||||
External[Actuators / Clients] -- communication protocol --> Package[Package Membrane: API]
|
||||
Skills[Dynamic Skills] -- API Calls --> Package
|
||||
Package --> Internal[Harness Internal Modules]
|
||||
style Package fill:#f9f,stroke:#333,stroke-width:4px
|
||||
#+end_src
|
||||
|
||||
** Public API Export
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
(defpackage :opencortex
|
||||
(:use :cl)
|
||||
(:export
|
||||
;; --- communication protocol ---
|
||||
#:frame-message
|
||||
#:read-framed-message
|
||||
#:PROTO-GET
|
||||
#:LIST-OBJECTS-WITH-ATTRIBUTE
|
||||
#:COSINE-SIMILARITY
|
||||
#:VAULT-MASK-STRING
|
||||
#:*VAULT-MEMORY*
|
||||
#:parse-message
|
||||
#:make-hello-message
|
||||
#:validate-communication-protocol-schema
|
||||
|
||||
;; --- Daemon Lifecycle ---
|
||||
#:start-daemon
|
||||
#:stop-daemon
|
||||
#:harness-log
|
||||
#:main
|
||||
|
||||
;; --- Memory (CLOSOS) ---
|
||||
#:ingest-ast
|
||||
#:lookup-object
|
||||
#:list-objects-by-type
|
||||
#:org-id-new
|
||||
#:*memory*
|
||||
#:*history-store*
|
||||
#:org-object
|
||||
#:make-org-object
|
||||
#:org-object-id
|
||||
#:org-object-type
|
||||
#:org-object-attributes
|
||||
#:org-object-parent-id
|
||||
#:org-object-children
|
||||
#:org-object-version
|
||||
#:org-object-last-sync
|
||||
#:org-object-vector
|
||||
#:org-object-content
|
||||
#:org-object-hash
|
||||
#:snapshot-memory
|
||||
#:rollback-memory
|
||||
|
||||
;; --- Context API (Peripheral Vision) ---
|
||||
#:context-query-store
|
||||
#:context-get-active-projects
|
||||
#:context-get-recent-completed-tasks
|
||||
#:context-list-all-skills
|
||||
#:context-get-skill-source
|
||||
#:context-get-system-logs
|
||||
#:context-resolve-path
|
||||
#:context-get-skill-telemetry
|
||||
#:harness-track-telemetry
|
||||
#:context-assemble-global-awareness
|
||||
|
||||
;; --- Reactive Signal Pipeline ---
|
||||
#:process-signal
|
||||
#:perceive-gate
|
||||
#:probabilistic-gate
|
||||
#:consensus-gate
|
||||
#:act-gate
|
||||
#:reason-gate
|
||||
#:perceive-gate
|
||||
#:dispatch-gate
|
||||
#:inject-stimulus
|
||||
#:initialize-actuators
|
||||
#:dispatch-action
|
||||
#:register-actuator
|
||||
|
||||
;; --- Skill Engine ---
|
||||
#:load-skill-from-org
|
||||
#:initialize-all-skills
|
||||
#:load-skill-with-timeout
|
||||
#:topological-sort-skills
|
||||
#:validate-lisp-syntax
|
||||
#:defskill
|
||||
#:*skills-registry*
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-dependencies
|
||||
#:skill-trigger-fn
|
||||
#:skill-probabilistic-prompt
|
||||
#:skill-deterministic-fn
|
||||
|
||||
;; --- Tool Registry ---
|
||||
#:def-cognitive-tool
|
||||
#:*cognitive-tools*
|
||||
#:cognitive-tool
|
||||
#:cognitive-tool-name
|
||||
#:cognitive-tool-description
|
||||
#:cognitive-tool-parameters
|
||||
#:cognitive-tool-guard
|
||||
#:cognitive-tool-body
|
||||
|
||||
;; --- Emacs Client Registry ---
|
||||
#:*emacs-clients*
|
||||
#:*clients-lock*
|
||||
#:register-emacs-client
|
||||
#:unregister-emacs-client
|
||||
|
||||
;; --- Probabilistic Engine ---
|
||||
#:ask-probabilistic
|
||||
#:register-probabilistic-backend
|
||||
#:distill-prompt
|
||||
#:*provider-cascade*
|
||||
|
||||
;; --- Security Vault ---
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
|
||||
;; --- Deterministic Logic ---
|
||||
#:list-objects-with-attribute
|
||||
#:deterministic-verify
|
||||
|
||||
;; --- AST Helpers ---
|
||||
#:find-headline-missing-id))
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
"Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
#+end_src
|
||||
|
||||
#+end_src
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
"Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
#+end_src
|
||||
|
||||
#+end_src
|
||||
|
||||
** Package Implementation
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Harness Logging State
|
||||
The harness maintains a thread-safe circular log buffer to provide context for debugging and neural reasoning.
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
(defvar *system-logs* nil)
|
||||
(defvar *logs-lock* (bt:make-lock "harness-logs-lock"))
|
||||
(defvar *max-log-history* 100)
|
||||
#+end_src
|
||||
|
||||
** Skills Registry
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded skills.")
|
||||
#+end_src
|
||||
|
||||
** Skill Telemetry State
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bt:make-lock "harness-telemetry-lock"))
|
||||
#+end_src
|
||||
|
||||
** Telemetry Implementation
|
||||
The system tracks the performance and reliability of individual skills. This logic is currently preserved in the package layer for future expansion into a dedicated telemetry skill.
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
(defun harness-track-telemetry (skill-name duration status)
|
||||
"Updates performance metrics for a specific skill. Status should be :success or :rejected."
|
||||
(when skill-name
|
||||
(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)))))
|
||||
#+end_src
|
||||
|
||||
** Cognitive Tool Registry
|
||||
The Tool Registry allows the agent to interact with the physical world. Every tool must define a guard (for security) and a body (for execution).
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
(defvar *cognitive-tools* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct cognitive-tool
|
||||
name
|
||||
description
|
||||
parameters
|
||||
guard
|
||||
body)
|
||||
|
||||
(defmacro def-cognitive-tool (name description parameters &key guard body)
|
||||
"Registers a new cognitive tool into the global registry. Parameters must be a list of property lists."
|
||||
`(setf (gethash (string-downcase (string ',name)) *cognitive-tools*)
|
||||
(make-cognitive-tool :name (string-downcase (string ',name))
|
||||
:description ,description
|
||||
:parameters ',parameters
|
||||
:guard ,guard
|
||||
:body ,body)))
|
||||
#+end_src
|
||||
|
||||
** Harness Logging Implementation
|
||||
Centralized logging function. It simultaneously writes to standard output and the in-memory circular buffer.
|
||||
|
||||
#+begin_src lisp :tangle ../library/package.lisp
|
||||
(defun harness-log (msg &rest args)
|
||||
"Centralized logging for the harness."
|
||||
(let ((formatted-msg (apply #'format nil msg args)))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(push formatted-msg *system-logs*)
|
||||
(when (> (length *system-logs*) *max-log-history*)
|
||||
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||
(format t "~a~%" formatted-msg)
|
||||
(finish-output)))
|
||||
#+end_src
|
||||
|
||||
|
||||
@@ -1,222 +0,0 @@
|
||||
#+TITLE: Stage 1: Perceive (perceive.lisp)
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :harness:perceive:
|
||||
#+STARTUP: content
|
||||
|
||||
* Stage 1: Perceive (perceive.lisp)
|
||||
|
||||
** Architectural Intent: Sensory Normalization
|
||||
|
||||
The Perceive stage is the "sensory cortex" of OpenCortex. Its job is to take raw stimuli from the outside world and transform them into standardized Signals that the rest of the pipeline can process.
|
||||
|
||||
Raw stimuli come from diverse sources:
|
||||
- Terminal input (CLI)
|
||||
- Emacs org-mode buffers (via swank)
|
||||
- Telegram/Signal messages
|
||||
- Heartbeats (internal clock)
|
||||
- Shell command outputs
|
||||
|
||||
Each source has its own format and protocol. Perceive normalizes all of them into the Signal format:
|
||||
|
||||
: (TYPE :EVENT META (...) PAYLOAD (...))
|
||||
|
||||
** Why Normalize?
|
||||
|
||||
Without normalization, each downstream component (Reason, Act) would need to understand each input format. With normalization:
|
||||
|
||||
1. The gateway layer (CLI, Emacs, Telegram) just sends raw messages
|
||||
2. Perceive transforms them into Signals
|
||||
3. Reason and Act work with a single, consistent format
|
||||
4. Adding new input sources only requires gateway code, not changes to the core
|
||||
|
||||
** The Signal Format
|
||||
|
||||
Signals are property lists with a consistent structure:
|
||||
|
||||
| Key | Description |
|
||||
|-----|-------------|
|
||||
| :type | :EVENT, :REQUEST, :RESPONSE, :LOG |
|
||||
| :payload | The actual content (sensor data, actions, etc.) |
|
||||
| :meta | Metadata: source, session, reply stream |
|
||||
| :status | Processing status: :perceived, :reasoned, :acted |
|
||||
| :depth | Recursion depth for feedback loops |
|
||||
| :approved-action | Set by Reason, executed by Act |
|
||||
| :foveal-focus | ID of the node user is interacting with |
|
||||
|
||||
** Async vs Sync Processing
|
||||
|
||||
Some sensors (user input, chat messages) are processed asynchronously in dedicated threads. This prevents:
|
||||
- A slow API call from blocking the entire system
|
||||
- Race conditions when multiple inputs arrive simultaneously
|
||||
|
||||
Other sensors (heartbeats, interrupts) are processed synchronously to maintain ordering guarantees.
|
||||
|
||||
* Package Context
|
||||
|
||||
#+begin_src lisp :tangle ../library/perceive.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
* Sensor Configuration
|
||||
|
||||
** Async Sensor Registry
|
||||
|
||||
#+begin_src lisp :tangle ../library/perceive.lisp
|
||||
(defvar *async-sensors* '(:chat-message :delegation :user-command)
|
||||
"Sensors that are processed in dedicated threads.
|
||||
|
||||
These sensors can block (waiting for API responses, user input, etc.)
|
||||
so they run in separate threads to avoid blocking the main pipeline.
|
||||
|
||||
Other sensors (:heartbeat, :interrupt, :buffer-update) are processed
|
||||
synchronously to maintain temporal ordering.")
|
||||
#+end_src
|
||||
|
||||
** Foveal Focus State
|
||||
|
||||
#+begin_src lisp :tangle ../library/perceive.lisp
|
||||
(defvar *foveal-focus-id* nil
|
||||
"The Org ID of the node the user is currently interacting with.
|
||||
|
||||
This enables the reasoning engine to provide contextually relevant
|
||||
responses. When editing a specific note, the agent knows which
|
||||
note you're referring to without needing explicit ID references.
|
||||
|
||||
Updated on :point-update events from Emacs.")
|
||||
#+end_src
|
||||
|
||||
* Stimulus Injection
|
||||
|
||||
** inject-stimulus: Entry Point
|
||||
|
||||
#+begin_src lisp :tangle ../library/perceive.lisp
|
||||
(defun inject-stimulus (raw-message &key stream (depth 0))
|
||||
"Inject a raw message into the signal processing pipeline.
|
||||
|
||||
RAW-MESSAGE is a property list that will be normalized into a Signal.
|
||||
STREAM is an optional output stream for responses (used by TUI/CLI).
|
||||
DEPTH tracks recursion depth for feedback loops.
|
||||
|
||||
This function determines whether to process synchronously or
|
||||
asynchronously based on the sensor type, then calls process-signal
|
||||
to run through the Perceive -> Reason -> Act pipeline.
|
||||
|
||||
Error handling: Uses restarts to prevent individual signals from
|
||||
crashing the entire system. Failed signals are logged and dropped."
|
||||
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
(sensor (getf payload :sensor))
|
||||
(meta (getf raw-message :meta))
|
||||
(async-p (or (getf payload :async-p)
|
||||
(member sensor *async-sensors*))))
|
||||
|
||||
;; Ensure metadata exists
|
||||
(unless meta
|
||||
(setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal")))
|
||||
|
||||
;; Attach reply stream if provided
|
||||
(when stream
|
||||
(setf (getf meta :reply-stream) stream))
|
||||
|
||||
(setf (getf raw-message :meta) meta)
|
||||
|
||||
(if async-p
|
||||
;; Async: process in dedicated thread
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(restart-case
|
||||
(handler-bind ((error (lambda (c)
|
||||
(harness-log "ASYNC ERROR: ~a" c)
|
||||
(invoke-restart 'skip-event))))
|
||||
(process-signal raw-message))
|
||||
(skip-event () nil)))
|
||||
:name "opencortex-async-task")
|
||||
|
||||
;; Sync: process in main thread with recovery
|
||||
(restart-case
|
||||
(handler-bind ((error (lambda (c)
|
||||
(harness-log "SYSTEM ERROR: ~a" c)
|
||||
(invoke-restart 'skip-event))))
|
||||
(process-signal raw-message))
|
||||
(skip-event ()
|
||||
(harness-log "SYSTEM RECOVERY: Stimulus dropped."))))))
|
||||
#+end_src
|
||||
|
||||
* The Perceive Gate
|
||||
|
||||
** perceive-gate: Signal Normalization
|
||||
|
||||
#+begin_src lisp :tangle ../library/perceive.lisp
|
||||
(defun perceive-gate (signal)
|
||||
"Stage 1 of the metabolic pipeline: Normalize sensory input.
|
||||
|
||||
This function:
|
||||
1. Logs the incoming signal for debugging
|
||||
2. Handles special sensor types (:buffer-update, :point-update, etc.)
|
||||
3. Updates the Memory graph with incoming data
|
||||
4. Tracks foveal focus (user's current node)
|
||||
5. Sets :status to :perceived
|
||||
|
||||
Modifies the signal in place and returns it for the next stage.
|
||||
|
||||
Memory snapshots are taken before AST updates to enable rollback
|
||||
if the update causes issues."
|
||||
|
||||
(let* ((payload (getf signal :payload))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(sensor (getf payload :sensor)))
|
||||
|
||||
;; Log the incoming signal for debugging
|
||||
(harness-log "GATE [Perceive]: ~a (~a) [Source: ~s]"
|
||||
type (or sensor "no-sensor") (getf meta :source))
|
||||
|
||||
;; Handle EVENT type sensors
|
||||
(cond ((eq type :EVENT)
|
||||
(case sensor
|
||||
|
||||
;; Org buffer was modified - update memory
|
||||
(:buffer-update
|
||||
(let ((ast (getf payload :ast)))
|
||||
(when ast
|
||||
(snapshot-memory) ; Enable rollback if update causes issues
|
||||
(ingest-ast ast))))
|
||||
|
||||
;; Point moved to different org node - update focus
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element
|
||||
(snapshot-memory)
|
||||
;; Track foveal focus for contextual reasoning
|
||||
(setf *foveal-focus-id*
|
||||
(ignore-errors (getf element :id)))
|
||||
(ingest-ast element))))
|
||||
|
||||
;; System interrupt - trigger shutdown
|
||||
(:interrupt
|
||||
(bt:with-lock-held (*interrupt-lock*)
|
||||
(setf *interrupt-flag* t)))))
|
||||
|
||||
;; Log responses from actuators
|
||||
((eq type :RESPONSE)
|
||||
(harness-log "GATE [Perceive]: Act Result -> ~a"
|
||||
(getf payload :status))))
|
||||
|
||||
;; Update signal status
|
||||
(setf (getf signal :status) :perceived)
|
||||
(setf (getf signal :foveal-focus) *foveal-focus-id*)
|
||||
signal))
|
||||
#+end_src
|
||||
|
||||
** Sensor Types Reference
|
||||
|
||||
| Sensor | Source | Processing | Description |
|
||||
|--------|--------|------------|-------------|
|
||||
| :user-input | CLI/TUI | Async | Text input from terminal |
|
||||
| :chat-message | Telegram/Signal | Async | Messages from messaging apps |
|
||||
| :heartbeat | Internal | Sync | Periodic maintenance trigger |
|
||||
| :buffer-update | Emacs | Sync | Org buffer was modified |
|
||||
| :point-update | Emacs | Sync | Cursor moved to different headline |
|
||||
| :interrupt | System | Sync | SIGINT received |
|
||||
| :tool-output | Internal | Sync | Result from cognitive tool |
|
||||
| :loop-error | Internal | Sync | Error during signal processing |
|
||||
@@ -1,444 +0,0 @@
|
||||
#+TITLE: Stage 2: Reason (reason.lisp)
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :harness:reason:
|
||||
#+STARTUP: content
|
||||
|
||||
* Stage 2: Reason (reason.lisp)
|
||||
|
||||
** Architectural Intent: The Dual-Engine Cognitive Architecture
|
||||
|
||||
The Reason stage implements the core innovation of OpenCortex: the separation of probabilistic reasoning (neural/LLM) from deterministic verification (logic/safety).
|
||||
|
||||
This dual-engine design solves a fundamental problem in AI safety:
|
||||
|
||||
1. *Probabilistic Engine* - Uses LLMs for semantic understanding, natural language generation, and complex reasoning. It is powerful but can hallucinate, make syntax errors, or propose unsafe actions.
|
||||
|
||||
2. *Deterministic Engine* - Uses formal verification (skills) to check LLM proposals before execution. It is slower but provably correct.
|
||||
|
||||
The LLM proposes; the skills verify. This is the "Bouncer Pattern" - the deterministic engine is literally a bouncer that checks the LLM's proposals at the door before letting them through to execution.
|
||||
|
||||
** Why Plists for Communication?
|
||||
|
||||
The Reason stage communicates exclusively through property lists (plists). This design choice reflects the homoiconic nature of Lisp - plists are native data structures that can be read, written, and manipulated by the same code that processes them.
|
||||
|
||||
A plist message like:
|
||||
: (TYPE :REQUEST TARGET :CLI PAYLOAD (ACTION :MESSAGE TEXT "Hello"))
|
||||
|
||||
Is simultaneously:
|
||||
- Human-readable text
|
||||
- Machine-parseable data structure
|
||||
- Executable Lisp code
|
||||
|
||||
This means the reasoning pipeline can generate, modify, and execute its own communication protocol without external parsing.
|
||||
|
||||
* Package Context
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
* Probabilistic Engine (Neural/LLM Integration)
|
||||
|
||||
The probabilistic engine is responsible for all neural/LLM operations. It maintains a registry of provider backends and implements a cascading failover mechanism.
|
||||
|
||||
** Backend Registry Variables
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
(defvar *probabilistic-backends* (make-hash-table :test 'equal)
|
||||
"Registry mapping provider keywords (:openrouter, :ollama) to their calling functions.")
|
||||
|
||||
(defvar *provider-cascade* nil
|
||||
"Ordered list of provider keywords to try. First available provider wins.")
|
||||
|
||||
(defvar *model-selector-fn* nil
|
||||
"Optional function that selects a specific model for each provider.
|
||||
Signature: (funcall fn provider context) => model-name-string")
|
||||
|
||||
(defvar *consensus-enabled-p* nil
|
||||
"When T, run multiple providers and compare results for critical decisions.")
|
||||
#+end_src
|
||||
|
||||
** register-probabilistic-backend: Backend Registration
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
(defun register-probabilistic-backend (name fn)
|
||||
"Register a neural provider backend.
|
||||
|
||||
NAME is a keyword like :openrouter or :ollama.
|
||||
FN is a function with signature: (funcall fn prompt system-prompt &key model)
|
||||
returning either:
|
||||
- (list :status :success :content \"response text\")
|
||||
- (list :status :error :message \"error description\")
|
||||
- a simple string on success
|
||||
|
||||
Example registration:
|
||||
(register-probabilistic-backend :openrouter #'openrouter-call)"
|
||||
|
||||
(setf (gethash name *probabilistic-backends*) fn))
|
||||
#+end_src
|
||||
|
||||
** probabilistic-call: Cascade Dispatch
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
(defun probabilistic-call (prompt &key
|
||||
(system-prompt "You are the Probabilistic engine.")
|
||||
(cascade nil)
|
||||
(context nil))
|
||||
"Dispatch a neural request through the provider cascade.
|
||||
|
||||
PROMPT - The user's query or task description.
|
||||
SYSTEM-PROMPT - Instructions for how the LLM should behave.
|
||||
CASCADE - Override the default provider cascade.
|
||||
CONTEXT - Current signal context (for model selection).
|
||||
|
||||
Returns the LLM response as a string, or a failure plist if all providers fail.
|
||||
|
||||
The cascade mechanism ensures reliability: if OpenRouter is rate-limited,
|
||||
it automatically falls back to OpenAI, then Anthropic, etc."
|
||||
|
||||
(let ((backends (or cascade *provider-cascade*)))
|
||||
(or (dolist (backend backends)
|
||||
(let ((backend-fn (gethash backend *probabilistic-backends*)))
|
||||
(when backend-fn
|
||||
(harness-log "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
|
||||
;; Optional model selection based on context
|
||||
(let* ((model (when *model-selector-fn*
|
||||
(funcall *model-selector-fn* backend context)))
|
||||
(result (if model
|
||||
(funcall backend-fn prompt system-prompt :model model)
|
||||
(funcall backend-fn prompt system-prompt))))
|
||||
|
||||
;; Normalize result format
|
||||
(cond ((and (listp result) (eq (getf result :status) :success))
|
||||
(return (getf result :content)))
|
||||
((stringp result)
|
||||
(return result))
|
||||
(t
|
||||
(harness-log "PROBABILISTIC: Backend ~a failed: ~a"
|
||||
backend (getf result :message))))))))
|
||||
|
||||
;; All providers failed
|
||||
(list :type :LOG
|
||||
:payload (list :text "Neural Cascade Failure: All providers exhausted.")))))
|
||||
#+end_src
|
||||
|
||||
* Cognitive Proposal Generation (Think)
|
||||
|
||||
The `think` function is the heart of the probabilistic engine. It constructs a prompt from context, sends it to the LLM, and parses the response into a structured action.
|
||||
|
||||
** strip-markdown: Clean LLM Output
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
(defun strip-markdown (text)
|
||||
"Strip markdown formatting from LLM output.
|
||||
|
||||
LLMs often wrap their responses in code fences (```lisp ...```).
|
||||
This function removes those markers to extract the raw plist.
|
||||
|
||||
Handles:
|
||||
- Leading code fences with language tags: ```lisp
|
||||
- Trailing code fences: ```
|
||||
- Orphan closing fences: ```"
|
||||
|
||||
(if (and text (stringp text))
|
||||
(let ((cleaned text))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
|
||||
(string-trim '(#\Space #\Newline #\Tab) cleaned))
|
||||
text))
|
||||
#+end_src
|
||||
|
||||
** normalize-plist-keywords: Fix LLM Keyword Output
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
(defun normalize-plist-keywords (plist)
|
||||
"Normalize all keys in a plist to keywords.
|
||||
|
||||
LLMs often return plists with unquoted keys: (TYPE REQUEST ...)
|
||||
instead of keyword syntax: (:TYPE :REQUEST ...)
|
||||
|
||||
This function converts all symbol keys to their keyword equivalents,
|
||||
making the plist compatible with standard Lisp property accessors.
|
||||
|
||||
Example transformation:
|
||||
(TYPE REQUEST PAYLOAD (ACTION MESSAGE TEXT \"Hi\"))
|
||||
=> (:TYPE :REQUEST :PAYLOAD (:ACTION :MESSAGE :TEXT \"Hi\"))"
|
||||
|
||||
(when (listp plist)
|
||||
(loop for (k . rest) on plist by #'cddr
|
||||
collect (if (and (symbolp k) (not (keywordp k)))
|
||||
(intern (string k) :keyword)
|
||||
k)
|
||||
collect (car rest))))
|
||||
#+end_src
|
||||
|
||||
** think: Generate Action Proposal
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
(defun think (context)
|
||||
"Generate a Lisp action proposal based on current context.
|
||||
|
||||
This is the core cognitive function. It:
|
||||
|
||||
1. Finds the most relevant skill based on context
|
||||
2. Assembles global awareness (memory context, system logs)
|
||||
3. Constructs a detailed prompt with available tools
|
||||
4. Calls the LLM via probabilistic-call
|
||||
5. Parses the LLM response into a structured action plist
|
||||
|
||||
The LLM is instructed to respond with exactly ONE plist, never prose.
|
||||
This constraint makes parsing deterministic and prevents rambling.
|
||||
|
||||
Returns a plist with structure:
|
||||
(:TYPE :REQUEST :TARGET :CLI :PAYLOAD (:ACTION :MESSAGE :TEXT \"...\"))"
|
||||
|
||||
;; Gather context components
|
||||
(let* ((active-skill (find-triggered-skill context))
|
||||
(tool-belt (generate-tool-belt-prompt))
|
||||
(global-context (context-assemble-global-awareness))
|
||||
(system-logs (context-get-system-logs))
|
||||
(assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent")))
|
||||
|
||||
;; Generate prompt from skill or raw text
|
||||
(let* ((prompt-generator (when active-skill
|
||||
(skill-probabilistic-prompt active-skill)))
|
||||
(raw-prompt (if prompt-generator
|
||||
(funcall prompt-generator context)
|
||||
;; Fallback: use raw user input
|
||||
(let ((p (proto-get (proto-get context :payload) :text)))
|
||||
(if (and p (stringp p))
|
||||
p
|
||||
"Maintain metabolic stasis."))))
|
||||
(system-prompt (format nil
|
||||
"IDENTITY: ~a
|
||||
|
||||
You are a component of the OpenCortex neurosymbolic AI agent.
|
||||
Your task is to generate exactly ONE valid Lisp plist response.
|
||||
|
||||
MANDATE: Respond with ONE Lisp plist. Never output prose.
|
||||
|
||||
IMPORTANT: To reply to the user, you MUST use:
|
||||
(:TYPE :REQUEST :PAYLOAD (:ACTION :MESSAGE :TEXT \"<Response Text>\"))
|
||||
|
||||
To call a tool, you MUST use:
|
||||
(:TYPE :REQUEST :TARGET :TOOL :ACTION :CALL :TOOL \"<name>\" :ARGS (:arg1 \"val\"))
|
||||
|
||||
MANDATORY VALIDATION RULE: Before declaring any Lisp code edit complete,
|
||||
you MUST call the `:validate-lisp` tool with the proposed code. If the tool
|
||||
returns `:status :error`, read the `:reason` and `:failed` fields, fix the
|
||||
defect, and re-validate. You are strictly forbidden from relying on your
|
||||
own paren-balancing or syntax intuition.
|
||||
|
||||
PROVIDER RULE: Always use the default cascade provider unless a specific
|
||||
model or capability is required for the task.
|
||||
|
||||
AVAILABLE TOOLS:
|
||||
~a
|
||||
|
||||
GLOBAL CONTEXT:
|
||||
~a
|
||||
|
||||
RECENT LOGS:
|
||||
~a"
|
||||
assistant-name
|
||||
tool-belt
|
||||
global-context
|
||||
system-logs)))
|
||||
|
||||
;; Call LLM and process response
|
||||
(let* ((thought (probabilistic-call raw-prompt
|
||||
:system-prompt system-prompt
|
||||
:context context))
|
||||
(cleaned (strip-markdown thought))
|
||||
(meta (proto-get context :meta))
|
||||
(source (proto-get meta :source)))
|
||||
|
||||
(when cleaned
|
||||
(harness-log "THINK: LLM raw output = ~a"
|
||||
(subseq cleaned 0 (min 200 (length cleaned)))))
|
||||
|
||||
;; Parse LLM response
|
||||
(if (and cleaned (stringp cleaned) (> (length cleaned) 0))
|
||||
(let ((*read-eval* nil))
|
||||
(if (char= (char cleaned 0) #\()
|
||||
;; Response starts with paren - try to parse as plist
|
||||
(handler-case
|
||||
(let ((parsed (read-from-string cleaned)))
|
||||
(when parsed
|
||||
(harness-log "THINK: parsed = ~a" parsed)
|
||||
|
||||
;; Normalize keyword keys (LLM often returns TYPE instead of :TYPE)
|
||||
(let ((parsed-normalized (normalize-plist-keywords parsed))
|
||||
(type (proto-get parsed :TYPE))
|
||||
(target (or (proto-get parsed :TARGET)
|
||||
(proto-get parsed :target))))
|
||||
|
||||
(cond
|
||||
;; Recognized message type - use directly
|
||||
((member type '(:REQUEST :EVENT :STATUS :RESPONSE))
|
||||
(unless (proto-get parsed :target)
|
||||
(setf (getf parsed :target) (or source :CLI)))
|
||||
parsed-normalized)
|
||||
|
||||
;; Tool call detected - wrap in standard envelope
|
||||
((or (eq target :TOOL)
|
||||
(eq target :tool)
|
||||
(getf parsed :TOOL)
|
||||
(getf parsed :tool)
|
||||
(and (listp parsed)
|
||||
(listp (car parsed))
|
||||
(keywordp (caar parsed))))
|
||||
(list :TYPE :REQUEST
|
||||
:TARGET :TOOL
|
||||
:PAYLOAD (normalize-plist-keywords parsed)))
|
||||
|
||||
;; Unknown format - treat as user message
|
||||
(t
|
||||
(list :TYPE :REQUEST
|
||||
:TARGET (or source :CLI)
|
||||
:PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned)))))))
|
||||
(error (c)
|
||||
(harness-log "THINK ERROR: ~a" c)
|
||||
(list :TYPE :REQUEST
|
||||
:TARGET (or source :CLI)
|
||||
:PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))
|
||||
|
||||
;; No leading paren - treat as plain text message
|
||||
(list :TYPE :REQUEST
|
||||
:TARGET (or source :CLI)
|
||||
:PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))
|
||||
|
||||
;; No response from LLM
|
||||
thought)))))
|
||||
#+end_src
|
||||
|
||||
* Deterministic Engine (Formal Verification)
|
||||
|
||||
The deterministic engine runs all registered skills' verification functions. This is where safety checks, policy enforcement, and skill-specific processing happen.
|
||||
|
||||
** deterministic-verify: Skill Chain Verification
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
(defun deterministic-verify (proposed-action context)
|
||||
"Run all skill deterministic gates on a proposed action.
|
||||
|
||||
Each skill can define a deterministic function that either:
|
||||
- Passes the action through unchanged
|
||||
- Modifies the action (adds explanation, changes target, etc.)
|
||||
- Blocks the action (returns a :LOG message instead)
|
||||
|
||||
Skills are sorted by priority (highest first). A skill with higher
|
||||
priority can intercept and modify actions before lower-priority
|
||||
skills see them.
|
||||
|
||||
The Bouncer Pattern: If any skill returns a :LOG or :EVENT type,
|
||||
processing stops and that message is returned immediately. This
|
||||
allows skills to veto actions.
|
||||
|
||||
Example skill chain:
|
||||
1. Policy skill (priority 500) - checks for missing explanations
|
||||
2. Protocol validator (priority 95) - validates message schema
|
||||
3. Shell actuator guard (priority 50) - checks command whitelist"
|
||||
|
||||
(let ((current-action proposed-action)
|
||||
(skills nil))
|
||||
|
||||
;; Collect all skills with deterministic functions
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (skill-deterministic-fn skill)
|
||||
(push skill skills)))
|
||||
*skills-registry*)
|
||||
|
||||
;; Sort by priority (highest first)
|
||||
(setf skills (sort skills #'> :key #'skill-priority))
|
||||
|
||||
;; Run each skill's gate
|
||||
(dolist (skill skills)
|
||||
(let ((trigger (skill-trigger-fn skill))
|
||||
(gate (skill-deterministic-fn skill)))
|
||||
|
||||
;; Skill activates if no trigger or trigger returns true
|
||||
(when (or (null trigger)
|
||||
(ignore-errors (funcall trigger context)))
|
||||
|
||||
;; Run the gate
|
||||
(let ((next-action (funcall gate current-action context)))
|
||||
(let ((original-type (proto-get current-action :type)))
|
||||
|
||||
;; Check if skill intercepted (returned LOG/EVENT instead of REQUEST)
|
||||
(when (and (listp next-action)
|
||||
(member (proto-get next-action :type)
|
||||
'(:LOG :EVENT :log :event))
|
||||
(or (not (member original-type '(:LOG :EVENT :log :event)))
|
||||
(not (eq next-action current-action))))
|
||||
|
||||
;; Skill blocked or modified - stop processing
|
||||
(harness-log "DETERMINISTIC: Intercepted by skill '~a'"
|
||||
(skill-name skill))
|
||||
(return-from deterministic-verify next-action)))
|
||||
|
||||
;; Action passed through - continue to next skill
|
||||
(setf current-action next-action)))))
|
||||
|
||||
;; Return final action (may be modified by skills, or original if all passed)
|
||||
current-action))
|
||||
#+end_src
|
||||
|
||||
* Reason Gate (Pipeline Stage)
|
||||
|
||||
** reason-gate: The Stage Function
|
||||
|
||||
#+begin_src lisp :tangle ../library/reason.lisp
|
||||
(defun reason-gate (signal)
|
||||
"Stage 2 of the metabolic pipeline: Reason.
|
||||
|
||||
Transforms perceived signals into approved actions by combining:
|
||||
1. Probabilistic reasoning (LLM generates proposal)
|
||||
2. Deterministic verification (skills validate proposal)
|
||||
|
||||
Only processes :EVENT signals with :user-input or :chat-message sensors.
|
||||
Other signals pass through unchanged (heartbeats, tool outputs, etc.).
|
||||
|
||||
Modifies the signal in place by setting:
|
||||
- :approved-action - The final verified action, or NIL
|
||||
- :status - :reasoned
|
||||
|
||||
Returns the modified signal."
|
||||
|
||||
(let* ((type (proto-get signal :type))
|
||||
(payload (proto-get signal :payload))
|
||||
(sensor (proto-get payload :sensor)))
|
||||
|
||||
;; Only reason about user input, not internal signals
|
||||
(unless (and (eq type :EVENT)
|
||||
(member sensor '(:user-input :chat-message)))
|
||||
(return-from reason-gate signal))
|
||||
|
||||
;; Generate proposal via LLM
|
||||
(let ((candidate (think signal)))
|
||||
|
||||
(harness-log "REASON: candidate type = ~a" (type-of candidate))
|
||||
|
||||
;; Validate candidate is a proper plist (not an error string or symbol)
|
||||
(if (and candidate
|
||||
(listp candidate)
|
||||
(or (keywordp (car candidate))
|
||||
(eq (car candidate) 'TYPE)
|
||||
(eq (car candidate) 'type)))
|
||||
|
||||
;; Valid proposal - run through deterministic verification
|
||||
(setf (getf signal :approved-action)
|
||||
(deterministic-verify candidate signal))
|
||||
|
||||
;; Invalid response - log and drop
|
||||
(progn
|
||||
(harness-log "REASON: Invalid candidate type ~a, dropping"
|
||||
(type-of candidate))
|
||||
(setf (getf signal :approved-action) nil)))
|
||||
|
||||
(setf (getf signal :status) :reasoned)
|
||||
signal)))
|
||||
#+end_src
|
||||
@@ -1,280 +0,0 @@
|
||||
#+TITLE: Zero-to-One Setup (setup.org)
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :harness:setup:
|
||||
#+STARTUP: content
|
||||
|
||||
* Zero-to-One Setup (setup.org)
|
||||
The ~setup.org~ file defines the automated installation and initialization sequence for the OpenCortex.
|
||||
|
||||
** The Installer Script (opencortex.sh)
|
||||
#+begin_src bash :tangle ../opencortex.sh
|
||||
#!/bin/bash
|
||||
set -e
|
||||
|
||||
PORT=9105
|
||||
HOST="localhost"
|
||||
RED='\033[0;31m'; GREEN='\033[0;32m'; BLUE='\033[0;34m'; YELLOW='\033[0;33m'; NC='\033[0m'
|
||||
|
||||
command_exists() { command -v "$1" >/dev/null 2>&1; }
|
||||
|
||||
# Resolve symlinks to find the actual repository location
|
||||
SOURCE="${BASH_SOURCE[0]}"
|
||||
while [ -h "$SOURCE" ]; do
|
||||
DIR="$( cd -P "$( dirname "$SOURCE" )" && pwd )"
|
||||
SOURCE="$(readlink "$SOURCE")"
|
||||
[[ $SOURCE != /* ]] && SOURCE="$DIR/$SOURCE"
|
||||
done
|
||||
export SCRIPT_DIR="$( cd -P "$( dirname "$SOURCE" )" && pwd )"
|
||||
|
||||
# Load environment variables if they exist
|
||||
if [ -f "$SCRIPT_DIR/.env" ]; then
|
||||
while IFS="=" read -r key value || [ -n "$key" ]; do
|
||||
if [[ $key =~ ^[a-zA-Z_][a-zA-Z0-9_]*$ ]]; then
|
||||
val=$(echo "$value" | sed "s/^\"//;s/\"$//")
|
||||
export "$key=$val"
|
||||
fi
|
||||
done < "$SCRIPT_DIR/.env"
|
||||
[ -n "$ORG_AGENT_DAEMON_PORT" ] && PORT=$ORG_AGENT_DAEMON_PORT
|
||||
[ -n "$DAEMON_HOST" ] && HOST=$DAEMON_HOST
|
||||
fi
|
||||
|
||||
# --- 1. BOOTSTRAP ---
|
||||
# If the script is run standalone, it clones the full repo and restarts itself.
|
||||
if [ ! -d "$SCRIPT_DIR/.git" ] && [ ! -d "$HOME/.opencortex" ] && [[ ! "$(pwd)" =~ "opencortex" ]]; then
|
||||
echo -e "${BLUE}=== OpenCortex: Zero-to-One Bootstrapper ===${NC}"
|
||||
git clone ssh://git@10.10.10.201:2222/amr/opencortex.git ~/.opencortex
|
||||
cd ~/.opencortex && git submodule update --init --recursive
|
||||
exec ./opencortex.sh "$@"
|
||||
fi
|
||||
|
||||
# --- 2. SETUP ---
|
||||
setup_system() {
|
||||
NON_INTERACTIVE=false
|
||||
for arg in "$@"; do
|
||||
if [ "$arg" == "--non-interactive" ]; then NON_INTERACTIVE=true; fi
|
||||
done
|
||||
|
||||
echo -e "${BLUE}=== OpenCortex: Initializing System ===${NC}"
|
||||
echo -e "${YELLOW}--- Installing System Dependencies ---${NC}"
|
||||
if command_exists apt-get; then
|
||||
sudo apt-get update && sudo apt-get install -y sbcl emacs-nox rlwrap netcat-openbsd curl git socat libssl-dev libncurses5-dev libffi-dev zlib1g-dev libsqlite3-dev
|
||||
fi
|
||||
if [ ! -d "$HOME/quicklisp" ]; then
|
||||
curl -O https://beta.quicklisp.org/quicklisp.lisp
|
||||
sbcl --non-interactive --load quicklisp.lisp --eval "(quicklisp-quickstart:install)" --eval "(ql-util:without-prompting (ql:add-to-init-file))"
|
||||
rm quicklisp.lisp
|
||||
fi
|
||||
|
||||
cd "$SCRIPT_DIR"
|
||||
if [ ! -f .env ]; then
|
||||
if [ "$NON_INTERACTIVE" = true ]; then
|
||||
echo "Non-interactive mode: Using environment variables for .env creation."
|
||||
cp .env.example .env
|
||||
[ -n "$MEMEX_USER" ] && sed -i "s|MEMEX_USER=.*|MEMEX_USER=\"$MEMEX_USER\"|" .env
|
||||
[ -n "$MEMEX_ASSISTANT" ] && sed -i "s|MEMEX_ASSISTANT=.*|MEMEX_ASSISTANT=\"$MEMEX_ASSISTANT\"|" .env
|
||||
[ -n "$OPENROUTER_API_KEY" ] && sed -i "s|OPENROUTER_API_KEY=.*|OPENROUTER_API_KEY=\"$OPENROUTER_API_KEY\"|" .env
|
||||
[ -n "$MEMEX_DIR" ] && sed -i "s|MEMEX_DIR=.*|MEMEX_DIR=\"$MEMEX_DIR\"|" .env
|
||||
else
|
||||
cp .env.example .env
|
||||
echo -e "\n${YELLOW}--- Identity Configuration ---${NC}"
|
||||
read -p "Your Name [User]: " user_name < /dev/tty
|
||||
user_name=${user_name:-User}
|
||||
sed -i "s|MEMEX_USER=.*|MEMEX_USER=\"$user_name\"|" .env
|
||||
|
||||
read -p "Agent Name [OpenCortex]: " agent_name < /dev/tty
|
||||
agent_name=${agent_name:-OpenCortex}
|
||||
sed -i "s|MEMEX_ASSISTANT=.*|MEMEX_ASSISTANT=\"$agent_name\"|" .env
|
||||
|
||||
echo -e "\n${YELLOW}--- LLM Configuration ---${NC}"
|
||||
read -p "OpenRouter API Key: " openrouter_key < /dev/tty
|
||||
[ -n "$openrouter_key" ] && sed -i "s|OPENROUTER_API_KEY=.*|OPENROUTER_API_KEY=\"$openrouter_key\"|" .env
|
||||
|
||||
echo -e "\n${YELLOW}--- Memex Folder Structure ---${NC}"
|
||||
read -p "Memex Root [\$HOME/memex]: " memex_dir < /dev/tty
|
||||
memex_dir=${memex_dir:-\$HOME/memex}
|
||||
sed -i "s|MEMEX_DIR=.*|MEMEX_DIR=\"$memex_dir\"|" .env
|
||||
fi
|
||||
|
||||
# Hydrate default paths
|
||||
M_DIR=$(grep MEMEX_DIR .env | cut -d'"' -f2 | sed "s|\$HOME|$HOME|")
|
||||
sed -i "s|SKILLS_DIR=.*|SKILLS_DIR=\"$SCRIPT_DIR/skills\"|" .env
|
||||
sed -i "s|ZETTELKASTEN_DIR=.*|ZETTELKASTEN_DIR=\"$M_DIR/notes\"|" .env
|
||||
mkdir -p "$M_DIR" "$M_DIR/notes" "$M_DIR/areas" "$M_DIR/resources" "$M_DIR/archives" "$M_DIR/system" "$M_DIR/inbox" "$M_DIR/daily" "$M_DIR/projects"
|
||||
fi
|
||||
|
||||
mkdir -p library
|
||||
for f in harness/*.org skills/*.org; do
|
||||
emacs -Q --batch --eval "(require 'org)" --eval "(org-babel-tangle-file \"$f\")" >/dev/null 2>&1 || true
|
||||
done
|
||||
|
||||
mkdir -p "$HOME/.local/bin"
|
||||
ln -sf "$SCRIPT_DIR/opencortex.sh" "$HOME/.local/bin/opencortex"
|
||||
|
||||
for shell_config in "$HOME/.bashrc" "$HOME/.profile"; do
|
||||
if [ -f "$shell_config" ]; then
|
||||
if ! grep -q ".local/bin" "$shell_config"; then
|
||||
echo 'export PATH="$HOME/.local/bin:$PATH"' >> "$shell_config"
|
||||
fi
|
||||
fi
|
||||
done
|
||||
export PATH="$HOME/.local/bin:$PATH"
|
||||
|
||||
echo -e "${YELLOW}--- Compiling and Loading OpenCortex ---${NC}"
|
||||
sbcl --non-interactive --eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' --eval '(push (truename (uiop:getenv "SCRIPT_DIR")) asdf:*central-registry*)' --eval "(ql:quickload '(:opencortex :croatoan))"
|
||||
|
||||
if [ $? -ne 0 ]; then
|
||||
echo -e "${RED}✗ Compilation failed.${NC}"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
if [ "$NON_INTERACTIVE" = true ]; then
|
||||
echo "Setup complete (Non-interactive)."
|
||||
exit 0
|
||||
fi
|
||||
|
||||
echo -e "${YELLOW}--- Finalizing: Awakening the Brain ---${NC}"
|
||||
"$SCRIPT_DIR/opencortex.sh" --boot > "$SCRIPT_DIR/brain.log" 2>&1 &
|
||||
|
||||
success=false
|
||||
for i in {1..30}; do
|
||||
if nc -z localhost $PORT 2>/dev/null; then success=true; break; fi
|
||||
sleep 2
|
||||
echo -n "."
|
||||
done
|
||||
|
||||
if [ "$success" = true ]; then
|
||||
echo -e "\n${GREEN}✓ Brain is alive on port $PORT.${NC}"
|
||||
exit 0
|
||||
else
|
||||
echo -e "\n${RED}✗ Brain failed to wake up.${NC}"
|
||||
exit 1
|
||||
fi
|
||||
}
|
||||
|
||||
# --- 3. COMMAND ROUTER ---
|
||||
COMMAND=$1
|
||||
[ -z "$COMMAND" ] && COMMAND="cli"
|
||||
shift || true
|
||||
|
||||
DEFAULT_PORT=9105
|
||||
DEFAULT_HOST="localhost"
|
||||
TARGET_PORT=${PORT:-$DEFAULT_PORT}
|
||||
TARGET_HOST=${HOST:-$DEFAULT_HOST}
|
||||
|
||||
# If uninitialized, force setup.
|
||||
if [ ! -f "$SCRIPT_DIR/library/package.lisp" ] || [ ! -f "$SCRIPT_DIR/.env" ]; then
|
||||
COMMAND="setup"
|
||||
fi
|
||||
|
||||
case "$COMMAND" in
|
||||
setup)
|
||||
setup_system "$@"
|
||||
;;
|
||||
|
||||
--boot|boot)
|
||||
export SKILLS_DIR="${SCRIPT_DIR}/skills"
|
||||
[ -z "$MEMEX_DIR" ] && export MEMEX_DIR="$HOME/memex"
|
||||
if [ -f "$SCRIPT_DIR/.env" ]; then
|
||||
export OPENROUTER_API_KEY=$(grep OPENROUTER_API_KEY "$SCRIPT_DIR/.env" | cut -d'"' -f2)
|
||||
fi
|
||||
exec sbcl --non-interactive --eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' --eval '(setf *debugger-hook* (lambda (c h) (declare (ignore h)) (format *error-output* "FATAL LISP ERROR: ~a~%" c) (uiop:print-backtrace :stream *error-output*) (uiop:quit 1)))' --eval '(push (truename (uiop:getenv "SCRIPT_DIR")) asdf:*central-registry*)' --eval '(format t "--- Quickloading OpenCortex ---~%")' --eval "(ql:quickload '(:opencortex :croatoan))" --eval '(opencortex:main)'
|
||||
;;
|
||||
|
||||
tui)
|
||||
if ! nc -z $TARGET_HOST $TARGET_PORT 2>/dev/null; then
|
||||
echo -e "Brain is offline. Awakening..."
|
||||
"$SCRIPT_DIR/opencortex.sh" --boot > "$SCRIPT_DIR/brain.log" 2>&1 &
|
||||
for i in {1..15}; do
|
||||
sleep 2
|
||||
if nc -z $TARGET_HOST $TARGET_PORT 2>/dev/null; then break; fi
|
||||
echo -n "."
|
||||
done
|
||||
echo ""
|
||||
fi
|
||||
echo -e "Launching Croatoan TUI..."
|
||||
export SKILLS_DIR="${SCRIPT_DIR}/skills"
|
||||
[ -z "$MEMEX_DIR" ] && export MEMEX_DIR="$HOME/memex"
|
||||
exec sbcl --eval '(load (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))' --eval '(push (truename (uiop:getenv "SCRIPT_DIR")) asdf:*central-registry*)' --eval '(ql:quickload :opencortex/tui)' --eval '(opencortex.tui:main)'
|
||||
;;
|
||||
|
||||
cli)
|
||||
if ! nc -z $TARGET_HOST $TARGET_PORT 2>/dev/null; then
|
||||
echo -e "Brain is offline. Awakening..."
|
||||
"$SCRIPT_DIR/opencortex.sh" --boot > "$SCRIPT_DIR/brain.log" 2>&1 &
|
||||
for i in {1..15}; do
|
||||
sleep 2
|
||||
if nc -z $TARGET_HOST $TARGET_PORT 2>/dev/null; then break; fi
|
||||
echo -n "."
|
||||
done
|
||||
echo ""
|
||||
fi
|
||||
if command_exists socat; then
|
||||
echo -e "Connected to OpenCortex on $TARGET_HOST:$TARGET_PORT (Channel: CLI)"
|
||||
while true; do
|
||||
read -p "User: " MESSAGE
|
||||
if [ -z "$MESSAGE" ]; then continue; fi
|
||||
if [ "$MESSAGE" = "/exit" ]; then break; fi
|
||||
|
||||
# Frame the message
|
||||
PAYLOAD="(:TYPE :EVENT :META (:SOURCE :CLI) :PAYLOAD (:SENSOR :USER-INPUT :TEXT \"$MESSAGE\"))"
|
||||
LEN=$(printf "%s" "$PAYLOAD" | wc -c)
|
||||
HEXLEN=$(printf "%06x" $LEN)
|
||||
|
||||
# Send and read response
|
||||
(printf "%s%s" "$HEXLEN" "$PAYLOAD" | nc -N $TARGET_HOST $TARGET_PORT) | while read -r LINE; do
|
||||
CLEAN=$(echo "$LINE" | sed 's/^......//')
|
||||
if [[ "$CLEAN" == *":TEXT"* ]]; then
|
||||
TEXT=$(echo "$CLEAN" | sed -n 's/.*:TEXT "\([^"]*\)".*/\1/p')
|
||||
echo -e "Agent: $TEXT"
|
||||
fi
|
||||
done
|
||||
done
|
||||
else
|
||||
echo "Error: socat required for CLI interaction."
|
||||
exit 1
|
||||
fi
|
||||
;;
|
||||
|
||||
*)
|
||||
echo -e "Unknown command: $COMMAND"
|
||||
echo "Available commands: setup, boot, tui, cli"
|
||||
exit 1
|
||||
;;
|
||||
esac
|
||||
#+end_src
|
||||
|
||||
** Metabolic Docker Infrastructure (Dockerfile)
|
||||
#+begin_src dockerfile :tangle ../infrastructure/docker/Dockerfile
|
||||
FROM debian:bullseye-slim
|
||||
|
||||
ENV DEBIAN_FRONTEND=noninteractive
|
||||
|
||||
RUN apt-get update && apt-get install -y \
|
||||
sbcl \
|
||||
emacs-nox \
|
||||
curl \
|
||||
git \
|
||||
socat \
|
||||
netcat-openbsd \
|
||||
libssl-dev \
|
||||
libncurses5-dev \
|
||||
libffi-dev \
|
||||
zlib1g-dev \
|
||||
libsqlite3-dev \
|
||||
&& rm -rf /var/lib/apt/lists/*
|
||||
|
||||
# Install Quicklisp
|
||||
RUN curl -O https://beta.quicklisp.org/quicklisp.lisp \
|
||||
&& sbcl --non-interactive --load quicklisp.lisp --eval "(quicklisp-quickstart:install)" --eval "(ql-util:without-prompting (ql:add-to-init-file))" \
|
||||
&& rm quicklisp.lisp
|
||||
|
||||
WORKDIR /app
|
||||
COPY . .
|
||||
|
||||
# Initialize system in non-interactive mode
|
||||
RUN mkdir -p /root/memex && ./opencortex.sh setup --non-interactive
|
||||
|
||||
EXPOSE 9105
|
||||
|
||||
CMD ["./opencortex.sh", "boot"]
|
||||
#+end_src
|
||||
@@ -1,362 +0,0 @@
|
||||
#+TITLE: The Skill Engine (skills.lisp)
|
||||
#+AUTHOR: Amr
|
||||
#+FILETAGS: :harness:skills:
|
||||
#+STARTUP: content
|
||||
|
||||
* The Skill Engine (skills.lisp)
|
||||
** Architectural Intent: Late-Binding Intelligence
|
||||
|
||||
A static, hardcoded architecture is inherently fragile. The ~opencortex~ Skill Engine enables **Late-Binding Intelligence**, allowing the system to discover and integrate new cognitive capabilities (actuators, solvers, sensors) at runtime without a kernel restart.
|
||||
|
||||
** Global Skill Registry
|
||||
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun COSINE-SIMILARITY (v1 v2)
|
||||
"Computes the cosine similarity between two vectors.
|
||||
Both arguments should be sequences of numbers. Returns a value between -1.0 and 1.0."
|
||||
(let ((len1 (length v1)) (len2 (length v2)))
|
||||
(if (or (zerop len1) (zerop len2))
|
||||
0.0
|
||||
(let ((dot-product 0.0d0)
|
||||
(norm1 0.0d0)
|
||||
(norm2 0.0d0))
|
||||
(let ((len (min len1 len2)))
|
||||
(dotimes (i len)
|
||||
(let ((x (coerce (elt v1 i) 'double-float)))
|
||||
(let ((y (coerce (elt v2 i) 'double-float)))
|
||||
(incf dot-product (* x y))
|
||||
(incf norm1 (* x x))
|
||||
(incf norm2 (* y y))))))
|
||||
(if (or (zerop norm1) (zerop norm2))
|
||||
0.0
|
||||
(/ dot-product (sqrt (* norm1 norm2))))))))
|
||||
(defun VAULT-MASK-STRING (s) "[MASKED]") ; Stub
|
||||
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
|
||||
|
||||
|
||||
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn)
|
||||
|
||||
(defvar *skill-catalog* (make-hash-table :test 'equal)
|
||||
"A stateful tracking table for all skill files discovered in the environment.")
|
||||
|
||||
(defstruct skill-entry
|
||||
filename
|
||||
(status :discovered) ;; :discovered, :loading, :ready, :failed
|
||||
error-log
|
||||
(load-time 0))
|
||||
|
||||
(defun find-triggered-skill (context)
|
||||
"Returns the highest priority skill whose trigger matches context AND has a probabilistic prompt."
|
||||
(let ((triggered nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (and (skill-probabilistic-prompt skill)
|
||||
(ignore-errors (funcall (skill-trigger-fn skill) context)))
|
||||
(push skill triggered)))
|
||||
*skills-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
|
||||
(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic)
|
||||
"Registers a new skill into the global registry."
|
||||
`(setf (gethash (string-downcase (string ,name)) *skills-registry*)
|
||||
(make-skill :name (string-downcase (string ,name))
|
||||
:priority (or ,priority 10)
|
||||
:dependencies ',dependencies
|
||||
:trigger-fn ,trigger
|
||||
:probabilistic-prompt ,probabilistic
|
||||
:deterministic-fn ,deterministic)))
|
||||
|
||||
(defun resolve-skill-dependencies (skill-name)
|
||||
"Recursively resolves dependencies for a given skill name."
|
||||
(let ((resolved nil) (seen nil))
|
||||
(labels ((visit (name)
|
||||
(unless (member name seen :test #'equal)
|
||||
(push name seen)
|
||||
(let ((skill (gethash (string-downcase (string name)) *skills-registry*)))
|
||||
(when skill
|
||||
(dolist (dep (skill-dependencies skill))
|
||||
(visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name)
|
||||
(nreverse resolved))))
|
||||
#+end_src
|
||||
|
||||
** Skill File Analysis (parse-skill-metadata)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
(defun parse-skill-metadata (filepath)
|
||||
"Extracts ID and DEPENDS_ON tags using robust regex scanning."
|
||||
(let ((dependencies nil)
|
||||
(id nil)
|
||||
(content (uiop:read-file-string filepath)))
|
||||
;; Extract ID
|
||||
(multiple-value-bind (match regs)
|
||||
(ppcre:scan-to-strings "(?im:^:ID:\\s*([^\\s\\r\\n]+))" content)
|
||||
(when match (setf id (aref regs 0))))
|
||||
;; Extract all DEPENDS_ON lines
|
||||
(ppcre:do-register-groups (deps-string)
|
||||
("(?im:^#\\+DEPENDS_ON:\\s*(.*))" content)
|
||||
(let ((deps (ppcre:split "\\s+" (string-trim " " deps-string))))
|
||||
(setf dependencies (append dependencies (mapcar (lambda (s) (string-trim "[] " s)) deps)))))
|
||||
(values id (remove-if (lambda (s) (= 0 (length s))) dependencies))))
|
||||
#+end_src
|
||||
|
||||
** Dependency Resolution (topological-sort-skills)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
(defun topological-sort-skills (skills-dir)
|
||||
"Returns a list of skill filepaths sorted by dependency (dependencies first)."
|
||||
(let ((files (uiop:directory-files skills-dir "org-skill-*.org"))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
(id-to-file (make-hash-table :test 'equal))
|
||||
(result nil)
|
||||
(visited (make-hash-table :test 'equal))
|
||||
(stack (make-hash-table :test 'equal)))
|
||||
(dolist (file files)
|
||||
(let ((filename (pathname-name file)))
|
||||
(multiple-value-bind (id deps) (parse-skill-metadata file)
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
(when id (setf (gethash (string-downcase id) id-to-file) file))
|
||||
(setf (gethash (string-downcase filename) adj) deps))))
|
||||
(labels ((visit (file)
|
||||
(let* ((filename (pathname-name file))
|
||||
(node-key (string-downcase filename)))
|
||||
(unless (gethash node-key visited)
|
||||
(setf (gethash node-key stack) t)
|
||||
(dolist (dep (gethash node-key adj))
|
||||
(let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep)))
|
||||
(dep-key (string-downcase (if is-id-p (subseq dep 3) dep)))
|
||||
(dep-file (if is-id-p
|
||||
(gethash dep-key id-to-file)
|
||||
(or (gethash dep-key id-to-file)
|
||||
(gethash dep-key name-to-file)))))
|
||||
(when dep-file
|
||||
(let ((dep-filename (pathname-name dep-file)))
|
||||
(if (gethash (string-downcase dep-filename) stack)
|
||||
(error "Circular dependency detected: ~a -> ~a" filename dep-filename)
|
||||
(visit dep-file))))))
|
||||
(setf (gethash node-key stack) nil)
|
||||
(setf (gethash node-key visited) t)
|
||||
(push file result)))))
|
||||
(let ((filenames (sort (mapcar #'pathname-name files) #'string<)))
|
||||
(dolist (name filenames)
|
||||
(let ((file (gethash (string-downcase name) name-to-file)))
|
||||
(when file (visit file)))))
|
||||
(nreverse result))))
|
||||
#+end_src
|
||||
|
||||
** Jailed Loading (load-skill-from-org)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
"Checks if a string contains valid, readable Common Lisp forms.
|
||||
Delegates to the Lisp Validator skill when available; falls back to a basic
|
||||
reader check during early boot before the validator skill is loaded."
|
||||
(let ((result
|
||||
(if (fboundp 'lisp-validator-validate)
|
||||
(lisp-validator-validate code-string :strict nil)
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof) until (eq form :eof)))
|
||||
(list :status :success))
|
||||
(error (c)
|
||||
(list :status :error :reason (format nil "~a" c)))))))
|
||||
(if (eq (getf result :status) :success)
|
||||
(values t nil)
|
||||
(values nil (or (getf result :reason) "Lisp Validator rejected code.")))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses and evaluates Lisp blocks with :tangle directives from an Org file.
|
||||
Only loads blocks that specify a .lisp tangle target, ignoring tests and examples."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(setf (gethash skill-base-name *skill-catalog*) entry)
|
||||
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil)
|
||||
(collect-this-block nil)
|
||||
(lisp-code "")
|
||||
(pkg-name (intern (string-upcase (format nil "OPENCORTEX.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond ((uiop:string-prefix-p "#+begin_src lisp" (string-downcase clean-line))
|
||||
(setf in-lisp-block t)
|
||||
;; Only collect blocks with a :tangle directive pointing to a
|
||||
;; runtime .lisp file (exclude tests and :tangle no)
|
||||
(let ((tl (string-downcase clean-line)))
|
||||
(setf collect-this-block
|
||||
(and (search ":tangle" tl)
|
||||
(not (search ":tangle no" tl))
|
||||
(search ".lisp" tl)
|
||||
(not (search "tests/" tl))
|
||||
(not (search "test/" tl))))))
|
||||
((uiop:string-prefix-p "#+end_src" (string-downcase clean-line))
|
||||
(setf in-lisp-block nil)
|
||||
(setf collect-this-block nil))
|
||||
((and in-lisp-block collect-this-block)
|
||||
(unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":END:" (string-upcase clean-line)))
|
||||
(setf lisp-code (concatenate 'string lisp-code line (string #\Newline))))))))
|
||||
|
||||
(if (= (length lisp-code) 0)
|
||||
(progn (setf (skill-entry-status entry) :ready) t)
|
||||
(progn
|
||||
(multiple-value-bind (valid-p err) (validate-lisp-syntax lisp-code)
|
||||
(unless valid-p (error "Syntax Error: ~a" err)))
|
||||
(harness-log "HARNESS: Jailing skill '~a' in package ~a" skill-base-name pkg-name)
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl))))
|
||||
(use-package :opencortex new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
||||
(setf (skill-entry-status entry) :ready)
|
||||
t)))
|
||||
(error (c)
|
||||
(let ((msg (format nil "~a" c)))
|
||||
(harness-log "LOADER ERROR in skill '~a': ~a" skill-base-name msg)
|
||||
(setf (skill-entry-status entry) :failed)
|
||||
(setf (skill-entry-error-log entry) msg)
|
||||
nil)))))
|
||||
|
||||
(defun load-skill-with-timeout (filepath timeout-seconds)
|
||||
"Loads a skill Org file with a hard execution timeout."
|
||||
(let* ((finished nil)
|
||||
(thread (bt:make-thread (lambda ()
|
||||
(if (load-skill-from-org filepath)
|
||||
(setf finished t)
|
||||
(setf finished :error)))
|
||||
:name (format nil "loader-~a" (pathname-name filepath))))
|
||||
(start-time (get-internal-real-time))
|
||||
(timeout-units (truncate (* timeout-seconds internal-time-units-per-second))))
|
||||
(loop
|
||||
(when (eq finished t) (return :success))
|
||||
(when (eq finished :error) (return :error))
|
||||
(unless (bt:thread-alive-p thread) (return :error))
|
||||
(when (> (- (get-internal-real-time) start-time) timeout-units)
|
||||
(harness-log "HARNESS: Timing out skill ~a..." (pathname-name filepath))
|
||||
#+sbcl (sb-thread:terminate-thread thread)
|
||||
#-sbcl (bt:destroy-thread thread)
|
||||
(return :timeout))
|
||||
(sleep 0.05))))
|
||||
#+end_src
|
||||
|
||||
** Initializing All Skills (initialize-all-skills)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
(defun initialize-all-skills ()
|
||||
"Scans the directory defined by SKILLS_DIR and hot-loads skills using topological order."
|
||||
(let* ((env-path (uiop:getenv "SKILLS_DIR"))
|
||||
(skills-dir-str (or env-path (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))
|
||||
(resolved-path (context-resolve-path skills-dir-str))
|
||||
(skills-dir (if resolved-path (uiop:ensure-directory-pathname resolved-path) nil)))
|
||||
|
||||
(unless (and skills-dir (uiop:directory-exists-p skills-dir))
|
||||
(harness-log "HARNESS ERROR: Skills directory not found: ~a" skills-dir-str)
|
||||
(return-from initialize-all-skills nil))
|
||||
|
||||
(let ((sorted-files (topological-sort-skills skills-dir)))
|
||||
(let* ((mandatory-env (uiop:getenv "MANDATORY_SKILLS"))
|
||||
(mandatory-skills (if mandatory-env
|
||||
(mapcar (lambda (s) (string-trim '(#\Space #\" #\') s))
|
||||
(uiop:split-string mandatory-env :separator '( #\,)))
|
||||
'("org-skill-policy" "org-skill-bouncer"))))
|
||||
(dolist (req mandatory-skills)
|
||||
(unless (member req sorted-files :key #'pathname-name :test #'string-equal)
|
||||
(error "BOOT FAILURE: Mandatory skill '~a' not found in skills directory: ~a" req (uiop:native-namestring skills-dir))))
|
||||
|
||||
(harness-log "==================================================")
|
||||
(harness-log " LOADER: Initializing ~a skills..." (length sorted-files))
|
||||
|
||||
(dolist (file sorted-files)
|
||||
(let* ((skill-name (pathname-name file))
|
||||
(is-mandatory (member skill-name mandatory-skills :test #'string-equal)))
|
||||
(harness-log " LOADER: Loading ~a..." skill-name)
|
||||
(let ((status (load-skill-with-timeout file 5)))
|
||||
(unless (eq status :success)
|
||||
(if is-mandatory
|
||||
(error "BOOT FAILURE: Mandatory skill '~a' failed to load (Status: ~a)." skill-name status)
|
||||
(harness-log "LOADER WARNING: Skill '~a' failed to load." skill-name))))))
|
||||
|
||||
(let ((ready 0) (failed 0))
|
||||
(maphash (lambda (k v)
|
||||
(declare (ignore k))
|
||||
(if (eq (skill-entry-status v) :ready) (incf ready) (incf failed)))
|
||||
*skill-catalog*)
|
||||
(harness-log " LOADER: Boot Complete. [Ready: ~a] [Failed: ~a]" ready failed)
|
||||
(harness-log "==================================================")
|
||||
(values ready failed))))))
|
||||
#+end_src
|
||||
|
||||
** Toolbelt Prompt Generation (generate-tool-belt-prompt)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
(defun generate-tool-belt-prompt ()
|
||||
"Aggregates all registered cognitive tools into a descriptive prompt."
|
||||
(let ((output (format nil "AVAILABLE TOOLS:
|
||||
You can call tools by returning a Lisp plist: (:target :tool :action :call :tool <name> :args (...))
|
||||
|
||||
EXAMPLES:
|
||||
(:target :tool :action :call :tool \"eval\" :args (:code \"(+ 1 1)\"))
|
||||
(:target :tool :action :call :tool \"grep-search\" :args (:pattern \"autonomousty\"))
|
||||
(:target :tool :action :call :tool \"shell\" :args (:cmd \"ls -la\"))
|
||||
|
||||
---
|
||||
" )))
|
||||
(maphash (lambda (name tool)
|
||||
(setf output (concatenate 'string output
|
||||
(format nil "- ~a: ~a~% Parameters: ~s~%~%"
|
||||
name
|
||||
(cognitive-tool-description tool)
|
||||
(cognitive-tool-parameters tool)))))
|
||||
*cognitive-tools*)
|
||||
output))
|
||||
#+end_src
|
||||
|
||||
** The Default Tool Belt
|
||||
*** The Eval Tool (Internal Inspection)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
(def-cognitive-tool :eval "Evaluates raw Common Lisp code in the harness image. Use this for complex calculations or internal state inspection."
|
||||
((:code :type :string :description "The Lisp code to evaluate"))
|
||||
:guard (lambda (args context)
|
||||
(declare (ignore context))
|
||||
(let ((code (getf args :code)))
|
||||
(let ((harness-pkg (find-package :opencortex.skills.org-skill-lisp-validator)))
|
||||
(if harness-pkg
|
||||
(uiop:symbol-call :opencortex.skills.org-skill-lisp-validator :lisp-validator-validate code)
|
||||
t))))
|
||||
:body (lambda (args)
|
||||
(let ((code (getf args :code)))
|
||||
(handler-case (let ((result (eval (read-from-string code))))
|
||||
(format nil "~s" result))
|
||||
(error (c) (format nil "ERROR: ~a" c))))))
|
||||
#+end_src
|
||||
|
||||
*** The Grep Tool (File Discovery)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
(def-cognitive-tool :grep-search "Searches for a pattern in the project files."
|
||||
((:pattern :type :string :description "The regex pattern to search for")
|
||||
(:dir :type :string :description "Directory to search in (default is project root)"))
|
||||
:body (lambda (args)
|
||||
(let ((pattern (getf args :pattern))
|
||||
(dir (or (getf args :dir) (uiop:getenv "MEMEX_DIR"))))
|
||||
(uiop:run-program (list "grep" "-r" "-n" "--exclude-dir=node_modules" pattern dir)
|
||||
:output :string :ignore-error-status t))))
|
||||
#+end_src
|
||||
|
||||
*** The Shell Tool (Machine Actuation)
|
||||
#+begin_src lisp :tangle ../library/skills.lisp
|
||||
(def-cognitive-tool :shell "Executes a shell command on the local machine. Use this for file operations, system checks, or running tests."
|
||||
((:cmd :type :string :description "The full bash command to execute"))
|
||||
:guard (lambda (args context)
|
||||
(declare (ignore context))
|
||||
(let ((cmd (getf args :cmd)))
|
||||
(not (or (search "rm -rf /" cmd) (search ":(){ :|:& };:" cmd)))))
|
||||
:body (lambda (args)
|
||||
(let ((cmd (getf args :cmd)))
|
||||
(multiple-value-bind (out err code)
|
||||
(uiop:run-program (list "bash" "-c" cmd) :output :string :error-output :string :ignore-error-status t)
|
||||
(format nil "EXIT-CODE: ~a~%~%STDOUT:~%~a~%~%STDERR:~%~a" code out err)))))
|
||||
#+end_src
|
||||
@@ -1,174 +0,0 @@
|
||||
:PROPERTIES:
|
||||
:ID: tui-client-spec
|
||||
:CREATED: [2026-04-17 Fri 11:00]
|
||||
:END:
|
||||
#+TITLE: OpenCortex TUI Client (Standalone)
|
||||
#+STARTUP: content
|
||||
#+FILETAGS: :tui:ux:client:
|
||||
|
||||
* Overview
|
||||
The OpenCortex TUI Client is a standalone Common Lisp application built on **Croatoan**. It provides a real-time, multi-window interface for interacting with the OpenCortex daemon.
|
||||
|
||||
* Implementation
|
||||
#+begin_src lisp :tangle ../library/tui-client.lisp
|
||||
(in-package :cl-user)
|
||||
(defpackage :opencortex.tui
|
||||
(:use :cl :croatoan)
|
||||
(:export :main))
|
||||
(in-package :opencortex.tui)
|
||||
|
||||
(defvar *daemon-host* "127.0.0.1")
|
||||
(defvar *daemon-port* 9105)
|
||||
(defvar *socket* nil)
|
||||
(defvar *stream* nil)
|
||||
(defvar *chat-history* (list))
|
||||
(defvar *status-text* "Connecting...")
|
||||
(defvar *input-buffer* (make-array 0 :element-type 'char :fill-pointer 0 :adjustable t))
|
||||
(defvar *is-running* t)
|
||||
(defvar *queue-lock* (bt:make-lock))
|
||||
(defvar *incoming-msgs* nil)
|
||||
|
||||
(defun enqueue-msg (msg)
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(push msg *incoming-msgs*)))
|
||||
|
||||
(defun dequeue-msgs ()
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(let ((msgs (nreverse *incoming-msgs*)))
|
||||
(setf *incoming-msgs* nil)
|
||||
msgs)))
|
||||
|
||||
(defun clean-keywords (msg)
|
||||
(if (listp msg)
|
||||
(let ((clean nil))
|
||||
(loop for (k v) on msg by #'cddr
|
||||
do (push (intern (string k) :keyword) clean)
|
||||
(push v clean))
|
||||
(nreverse clean))
|
||||
msg))
|
||||
|
||||
(defun format-payload (payload)
|
||||
"Extracts human-readable text from a protocol payload, handling nested tool calls."
|
||||
(let* ((action (getf payload :ACTION))
|
||||
(text (getf payload :TEXT))
|
||||
(msg (getf payload :MESSAGE))
|
||||
(tool (getf payload :TOOL))
|
||||
(prompt (getf payload :PROMPT))
|
||||
(args (getf payload :ARGS))
|
||||
(result (getf payload :RESULT)))
|
||||
(cond (text text)
|
||||
(msg msg)
|
||||
((eq action :MESSAGE) (getf payload :TEXT))
|
||||
((and tool prompt) (format nil "THOUGHT [~a]: ~a" tool prompt))
|
||||
((and tool args)
|
||||
(let ((inner-prompt (or (getf args :PROMPT) (getf args :TEXT))))
|
||||
(if inner-prompt
|
||||
(format nil "THOUGHT [~a]: ~a" tool inner-prompt)
|
||||
(format nil "CALL [~a] (ARGS: ~s)" tool args))))
|
||||
(result (format nil "RESULT: ~a" result))
|
||||
(t (format nil "~s" payload)))))
|
||||
|
||||
(defun listen-thread ()
|
||||
(loop while *is-running* do
|
||||
(handler-case
|
||||
(when (and *stream* (open-stream-p *stream*))
|
||||
(let ((raw-msg (opencortex:read-framed-message *stream*)))
|
||||
(unless (member raw-msg '(:eof :error))
|
||||
(let* ((msg (clean-keywords raw-msg))
|
||||
(type (or (getf msg :TYPE) (getf msg :type)))
|
||||
(payload (or (getf msg :PAYLOAD) (getf msg :payload))))
|
||||
(cond ((and (listp msg) (eq type :EVENT))
|
||||
(let ((action (or (getf payload :ACTION) (getf payload :action)))
|
||||
(text (or (getf payload :TEXT) (getf payload :text) (getf payload :MESSAGE) (getf payload :message))))
|
||||
(cond ((eq action :handshake) (setf *status-text* "Ready"))
|
||||
(text (enqueue-msg (format nil "SYSTEM: ~a" text))))))
|
||||
((and (listp msg) (eq type :STATUS))
|
||||
(setf *status-text* (format nil "[Scribe: ~a] [Gardener: ~a]"
|
||||
(or (getf msg :SCRIBE) (getf msg :scribe))
|
||||
(or (getf msg :GARDENER) (getf msg :gardener)))))
|
||||
((and (listp msg) (member type '(:REQUEST :RESPONSE :LOG)))
|
||||
(let ((formatted (format-payload payload)))
|
||||
(when formatted (enqueue-msg formatted))))
|
||||
((and (listp msg) (eq type :EVENT) (eq (getf payload :SENSOR) :TOOL-OUTPUT))
|
||||
(let ((formatted (format-payload payload)))
|
||||
(when formatted (enqueue-msg formatted))))
|
||||
(t (harness-log "TUI: Ignored unknown type ~a" type)))))
|
||||
(when (eq raw-msg :eof) (setf *is-running* nil))
|
||||
(when (eq raw-msg :error) (setf *status-text* "Protocol Error"))))
|
||||
(error (c) (setf *status-text* (format nil "Net Error: ~a" c)) (setf *is-running* nil)))
|
||||
(sleep 0.05)))
|
||||
|
||||
(defun main ()
|
||||
(handler-case
|
||||
(setf *socket* (usocket:socket-connect *daemon-host* *daemon-port*))
|
||||
(error (e) (format t "Error connecting: ~a~%" e) (return-from main)))
|
||||
(setf *stream* (usocket:socket-stream *socket*))
|
||||
(bt:make-thread #'listen-thread :name "tui-listener")
|
||||
|
||||
(unwind-protect
|
||||
(with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t :cursor-visible t)
|
||||
(let* ((h (height scr))
|
||||
(w (width scr))
|
||||
(chat-win (make-instance 'window :height (- h 2) :width w :position (list 0 0)))
|
||||
(status-win (make-instance 'window :height 1 :width w :position (list (- h 2) 0)))
|
||||
(input-win (make-instance 'window :height 1 :width w :position (list (- h 1) 0)))
|
||||
(last-status nil))
|
||||
|
||||
(setf (function-keys-enabled-p input-win) t)
|
||||
(setf (input-blocking input-win) nil)
|
||||
|
||||
(loop while *is-running* do
|
||||
;; 1. Handle incoming messages
|
||||
(let ((new-msgs (dequeue-msgs)))
|
||||
(when new-msgs
|
||||
(dolist (msg new-msgs)
|
||||
(push msg *chat-history*)
|
||||
(setf *chat-history* (subseq *chat-history* 0 (min (length *chat-history*) 500))))
|
||||
|
||||
(clear chat-win)
|
||||
(let ((line-num 0))
|
||||
(dolist (m (reverse (subseq *chat-history* 0 (min (length *chat-history*) (- h 3)))))
|
||||
(add-string chat-win m :y line-num :x 0)
|
||||
(incf line-num)))
|
||||
(refresh chat-win)))
|
||||
|
||||
;; 2. Render Status Bar ONLY if changed
|
||||
(unless (equal *status-text* last-status)
|
||||
(clear status-win)
|
||||
(add-string status-win *status-text* :attributes '(:reverse))
|
||||
(refresh status-win)
|
||||
(setf last-status *status-text*))
|
||||
|
||||
;; 3. Handle Keyboard Input
|
||||
(let* ((event (get-wide-event input-win))
|
||||
(ch (and event (typep event 'event) (event-key event))))
|
||||
(when ch
|
||||
(cond
|
||||
((or (eq ch #\Newline) (eq ch #\Return))
|
||||
(let ((cmd (coerce *input-buffer* 'string)))
|
||||
(setf (fill-pointer *input-buffer*) 0)
|
||||
(when (> (length cmd) 0)
|
||||
;; Local Echo
|
||||
(enqueue-msg (concatenate 'string "> " cmd))
|
||||
;; Send to Brain
|
||||
(let ((framed (opencortex:frame-message (list :TYPE :EVENT
|
||||
:META (list :SOURCE :tui :SESSION-ID "default")
|
||||
:PAYLOAD (list :SENSOR :user-input :TEXT cmd)))))
|
||||
(format *stream* "~a" framed)
|
||||
(finish-output *stream*)))
|
||||
(when (string= cmd "/exit") (setf *is-running* nil))))
|
||||
((or (eq ch :backspace) (eq ch #\Backspace) (eq ch #\Rubout) (eq ch #\Del))
|
||||
(when (> (length *input-buffer*) 0)
|
||||
(decf (fill-pointer *input-buffer*))))
|
||||
((characterp ch)
|
||||
(vector-push-extend ch *input-buffer*))))
|
||||
|
||||
(clear input-win)
|
||||
(add-string input-win (concatenate 'string "> " (coerce *input-buffer* 'string)))
|
||||
(move input-win 0 (+ 2 (length *input-buffer*)))
|
||||
(refresh input-win))
|
||||
|
||||
(sleep 0.02))))
|
||||
(setf *is-running* nil)
|
||||
(when *socket* (usocket:socket-close *socket*))))
|
||||
#+end_src
|
||||
@@ -1,32 +1,23 @@
|
||||
FROM debian:bullseye-slim
|
||||
FROM debian:trixie-slim
|
||||
|
||||
ENV DEBIAN_FRONTEND=noninteractive
|
||||
|
||||
RUN apt-get update && apt-get install -y \
|
||||
sbcl \
|
||||
emacs-nox \
|
||||
curl \
|
||||
git \
|
||||
socat \
|
||||
netcat-openbsd \
|
||||
libssl-dev \
|
||||
libncurses5-dev \
|
||||
libffi-dev \
|
||||
zlib1g-dev \
|
||||
libsqlite3-dev \
|
||||
sbcl emacs-nox curl git socat netcat-openbsd rlwrap \
|
||||
libssl-dev libncurses-dev libffi-dev zlib1g-dev libsqlite3-dev \
|
||||
&& rm -rf /var/lib/apt/lists/*
|
||||
|
||||
# Install Quicklisp
|
||||
RUN curl -O https://beta.quicklisp.org/quicklisp.lisp \
|
||||
&& sbcl --non-interactive --load quicklisp.lisp --eval "(quicklisp-quickstart:install)" --eval "(ql-util:without-prompting (ql:add-to-init-file))" \
|
||||
&& sbcl --non-interactive --load quicklisp.lisp \
|
||||
--eval "(quicklisp-quickstart:install)" \
|
||||
--eval "(ql-util:without-prompting (ql:add-to-init-file))" \
|
||||
&& rm quicklisp.lisp
|
||||
|
||||
WORKDIR /app
|
||||
COPY . .
|
||||
|
||||
# Initialize system in non-interactive mode
|
||||
RUN mkdir -p /root/memex && ./opencortex.sh setup --non-interactive
|
||||
RUN mkdir -p /root/memex && ./opencortex.sh configure --non-interactive
|
||||
|
||||
EXPOSE 9105
|
||||
|
||||
CMD ["./opencortex.sh", "boot"]
|
||||
CMD ["./opencortex.sh", "daemon"]
|
||||
|
||||
@@ -1,18 +1,15 @@
|
||||
services:
|
||||
opencortex:
|
||||
passepartout:
|
||||
build:
|
||||
context: .
|
||||
dockerfile: Dockerfile
|
||||
container_name: opencortex
|
||||
env_file: .env
|
||||
context: ../../
|
||||
dockerfile: infrastructure/docker/Dockerfile
|
||||
container_name: passepartout
|
||||
env_file: ../../.env
|
||||
volumes:
|
||||
# Mount the entire memex directory (2 levels up from projects/opencortex)
|
||||
- ../..:/memex
|
||||
# Ensure signal-cli state is preserved
|
||||
- ../../../..:/memex
|
||||
- signal-state:/root/.local/share/signal-cli
|
||||
ports:
|
||||
- "${ORG_AGENT_DAEMON_PORT:-9105}:9105"
|
||||
- "${ORG_AGENT_WEB_PORT:-8080}:8080"
|
||||
restart: unless-stopped
|
||||
|
||||
volumes:
|
||||
|
||||
15
infrastructure/opencortex.service
Normal file
15
infrastructure/opencortex.service
Normal file
@@ -0,0 +1,15 @@
|
||||
[Unit]
|
||||
Description=OpenCortex Daemon
|
||||
Documentation=https://github.com/amrgharbeia/opencortex
|
||||
After=network.target
|
||||
|
||||
[Service]
|
||||
Type=simple
|
||||
User=%u
|
||||
ExecStart=%h/projects/passepartout/opencortex.sh daemon
|
||||
Restart=on-failure
|
||||
RestartSec=10
|
||||
WorkingDirectory=%h/projects/passepartout
|
||||
|
||||
[Install]
|
||||
WantedBy=default.target
|
||||
15
infrastructure/passepartout.service
Normal file
15
infrastructure/passepartout.service
Normal file
@@ -0,0 +1,15 @@
|
||||
[Unit]
|
||||
Description=Passepartout Daemon
|
||||
Documentation=https://github.com/amrgharbeia/opencortex
|
||||
After=network.target
|
||||
|
||||
[Service]
|
||||
Type=simple
|
||||
User=%u
|
||||
ExecStart=%h/projects/passepartout/passepartout daemon
|
||||
Restart=on-failure
|
||||
RestartSec=10
|
||||
WorkingDirectory=%h/projects/passepartout
|
||||
|
||||
[Install]
|
||||
WantedBy=default.target
|
||||
148
library/act.lisp
148
library/act.lisp
@@ -1,148 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *default-actuator* :cli)
|
||||
(defvar *silent-actuators* '(:cli :system-message :emacs))
|
||||
|
||||
(defun initialize-actuators ()
|
||||
"Loads actuator routing defaults from environment variables and registers core harness actuators."
|
||||
(let ((def (uiop:getenv "DEFAULT_ACTUATOR"))
|
||||
(silent (uiop:getenv "SILENT_ACTUATORS")))
|
||||
(when def
|
||||
(setf *default-actuator* (intern (string-upcase def) "KEYWORD")))
|
||||
(when silent
|
||||
(setf *silent-actuators*
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) "KEYWORD"))
|
||||
(str:split "," silent)))))
|
||||
|
||||
;; Register core harness actuators
|
||||
(register-actuator :system #'execute-system-action)
|
||||
(register-actuator :tool #'execute-tool-action)
|
||||
(register-actuator :tui (lambda (action context)
|
||||
(let* ((meta (getf context :meta))
|
||||
(stream (getf meta :reply-stream)))
|
||||
(when (and stream (open-stream-p stream))
|
||||
(format stream "~a" (frame-message action))
|
||||
(finish-output stream))))))
|
||||
|
||||
(defun dispatch-action (action context)
|
||||
(let ((payload (proto-get action :payload)))
|
||||
(when (eq (proto-get payload :sensor) :heartbeat)
|
||||
(return-from dispatch-action nil)))
|
||||
"Routes an approved action to its registered physical actuator."
|
||||
(when (and action (listp action))
|
||||
(let* ((meta (proto-get context :meta))
|
||||
(source (proto-get meta :source))
|
||||
(raw-target (or (ignore-errors (getf action :TARGET))
|
||||
(ignore-errors (getf action :target))
|
||||
source
|
||||
*default-actuator*))
|
||||
(target (intern (string-upcase (string raw-target)) :keyword))
|
||||
(actuator-fn (gethash target *actuator-registry*)))
|
||||
;; Ensure outbound action has meta if context had it
|
||||
(when (and meta (null (getf action :meta)))
|
||||
(setf (getf action :meta) meta))
|
||||
(if actuator-fn
|
||||
(funcall actuator-fn action context)
|
||||
(harness-log "ACT ERROR: No actuator for ~s (from ~s)" target raw-target)))))
|
||||
|
||||
(defun execute-system-action (action context)
|
||||
"Processes internal harness commands. (ACTUATOR)"
|
||||
(declare (ignore context))
|
||||
(let* ((payload (ignore-errors (getf action :payload)))
|
||||
(cmd (ignore-errors (getf payload :action))))
|
||||
(case cmd
|
||||
(:eval (let ((code (getf payload :code)))
|
||||
(eval (read-from-string code))))
|
||||
(:create-skill (let* ((filename (getf payload :filename)) (content (getf payload :content))
|
||||
(skills-dir (merge-pathnames "skills/" (asdf:system-source-directory :opencortex)))
|
||||
(full-path (merge-pathnames filename skills-dir)))
|
||||
(with-open-file (out full-path :direction :output :if-exists :supersede) (write-string content out))
|
||||
(load-skill-from-org full-path)))
|
||||
(:message (harness-log "ACT [System]: ~a" (getf payload :text)))
|
||||
(t (harness-log "ACT ERROR [System]: Unknown command ~s" cmd)))))
|
||||
|
||||
(defun format-tool-result (tool-name result)
|
||||
"Intelligently formats a tool result for user display."
|
||||
(if (listp result)
|
||||
(let ((status (getf result :status))
|
||||
(content (getf result :content))
|
||||
(msg (getf result :message)))
|
||||
(cond ((and (eq status :success) content) (format nil "~a" content))
|
||||
((and (eq status :error) msg) (format nil "ERROR [~a]: ~a" tool-name msg))
|
||||
(t (format nil "TOOL [~a] RESULT: ~s" tool-name result))))
|
||||
(format nil "TOOL [~a] RESULT: ~a" tool-name result)))
|
||||
|
||||
(defun execute-tool-action (action context)
|
||||
"Executes a registered cognitive tool. (ACTUATOR)"
|
||||
(let* ((payload (getf action :payload))
|
||||
(tool-name (getf payload :tool))
|
||||
(tool-args (getf payload :args))
|
||||
(depth (getf context :depth 0))
|
||||
(meta (getf context :meta))
|
||||
(source (getf meta :source))
|
||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
||||
(if tool
|
||||
(handler-case
|
||||
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
||||
(result (funcall (cognitive-tool-body tool) clean-args)))
|
||||
(let ((feedback (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-output :RESULT result :TOOL tool-name))))
|
||||
;; If we have a source, send a status message with the result, formatted for humans
|
||||
(when source
|
||||
(dispatch-action (list :TYPE :REQUEST :TARGET source
|
||||
:PAYLOAD (list :ACTION :MESSAGE :TEXT (format-tool-result tool-name result)))
|
||||
context))
|
||||
feedback))
|
||||
(error (c)
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error :tool tool-name :message (format nil "~a" c)))))
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error :message "Tool not found")))))
|
||||
|
||||
(defun act-gate (signal)
|
||||
"Final Stage: Actuation and feedback generation."
|
||||
(let* ((approved (getf signal :approved-action))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(source (getf meta :source))
|
||||
(feedback nil)
|
||||
;; context must keep internal objects for actuators to function
|
||||
(context signal))
|
||||
|
||||
;; 1. Last-Mile Safety Check (The Bouncer & Deterministic Gates)
|
||||
(when approved
|
||||
(let* ((original-type (getf approved :type))
|
||||
(verified (deterministic-verify approved signal)))
|
||||
(if (and (listp verified)
|
||||
(member (getf verified :type) '(:LOG :EVENT :log :event))
|
||||
(not (member original-type '(:LOG :EVENT :log :event))))
|
||||
(progn
|
||||
(harness-log "ACT BLOCKED: Action failed last-mile deterministic check.")
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf approved nil)
|
||||
(setf feedback verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf approved verified)))))
|
||||
|
||||
;; 2. Actuation Logic
|
||||
(case type
|
||||
(:REQUEST (dispatch-action signal context))
|
||||
(:LOG (dispatch-action signal context))
|
||||
(:EVENT
|
||||
(if approved
|
||||
(let* ((target (getf approved :target))
|
||||
(result (dispatch-action approved context)))
|
||||
;; If the actuator returns a signal (like :tool-output), it becomes the feedback.
|
||||
;; Otherwise, generate tool-output feedback for non-silent actuators.
|
||||
(cond ((and (listp result) (member (getf result :type) '(:EVENT :LOG)))
|
||||
(setf feedback result))
|
||||
((and result (not (member target *silent-actuators*)))
|
||||
(setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta
|
||||
:payload (list :sensor :tool-output :result result :tool approved))))))
|
||||
;; If no approved action but we have a source, this might be a raw event/log stimulus.
|
||||
(when source
|
||||
(dispatch-action signal context)))))
|
||||
|
||||
(setf (getf signal :status) :acted)
|
||||
feedback))
|
||||
@@ -1,44 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Strict structural validation for incoming communication protocol messages."
|
||||
(unless (listp msg)
|
||||
(error "Communication Protocol Schema Error: Message must be a property list (got ~s)" (type-of msg)))
|
||||
|
||||
(let ((type (let ((raw (proto-get msg :type))) (if (keywordp raw) (intern (string-upcase (string raw)) :keyword) raw))))
|
||||
(unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS))
|
||||
(progn (harness-log "REJECTED MSG: ~s" msg) (error "Communication Protocol Schema Error: Invalid message type '~a'" type)))
|
||||
|
||||
(case type
|
||||
(:REQUEST
|
||||
;; Allow missing :target if :source is present in :meta, since reason-gate
|
||||
;; will infer :target from :source downstream. This preserves "equality of
|
||||
;; clients" — gateways need not duplicate routing logic.
|
||||
(let ((target (proto-get msg :target))
|
||||
(source (proto-get (proto-get msg :meta) :source)))
|
||||
(unless (or target source)
|
||||
(error "Communication Protocol Schema Error: REQUEST missing mandatory :target and no :source in :meta to infer it"))
|
||||
(unless (proto-get msg :payload)
|
||||
(error "Communication Protocol Schema Error: REQUEST missing mandatory :payload"))))
|
||||
|
||||
(:EVENT
|
||||
(let ((payload (proto-get msg :payload)))
|
||||
(unless (and payload (listp payload))
|
||||
(error "Communication Protocol Schema Error: EVENT missing or invalid :payload"))
|
||||
(unless (or (proto-get payload :action) (proto-get payload :sensor))
|
||||
(error "Communication Protocol Schema Error: EVENT payload must contain :action or :sensor"))))
|
||||
|
||||
(:RESPONSE
|
||||
(unless (proto-get msg :payload)
|
||||
(error "Communication Protocol Schema Error: RESPONSE missing mandatory :payload"))))
|
||||
|
||||
t))
|
||||
|
||||
(defskill :skill-communication-protocol-validator
|
||||
:priority 95
|
||||
:trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:protocol-received)))
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(validate-communication-protocol-schema action)
|
||||
action))
|
||||
@@ -1,75 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
||||
"Global registry mapping target keywords to their physical actuator functions.")
|
||||
|
||||
(defun register-actuator (name fn)
|
||||
"Registers an actuator function. Actuators receive: (ACTION CONTEXT)."
|
||||
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
||||
(setf (gethash key *actuator-registry*) fn)))
|
||||
|
||||
(defun frame-message (msg-plist)
|
||||
"Frames a Lisp plist with a 6-character hex length and a newline for stream integrity."
|
||||
(let* ((*print-pretty* nil)
|
||||
(*print-circle* nil)
|
||||
(msg-string (format nil "~s" msg-plist))
|
||||
(len (length msg-string)))
|
||||
(format nil "~6,'0x~a~%" len msg-string)))
|
||||
|
||||
(defun read-framed-message (stream)
|
||||
"Reads a hex-length prefixed S-expression from the stream securely. Skips leading whitespace."
|
||||
(let ((length-buffer (make-string 6)))
|
||||
(handler-case
|
||||
(progn
|
||||
;; 1. Skip leading whitespace (newlines, spaces, etc.)
|
||||
(loop for char = (peek-char nil stream nil :eof)
|
||||
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return)))
|
||||
do (read-char stream))
|
||||
|
||||
;; 2. Read the 6-char hex length
|
||||
(let ((count (read-sequence length-buffer stream)))
|
||||
(cond ((< count 6) :eof)
|
||||
(t (let ((len (ignore-errors (parse-integer length-buffer :radix 16))))
|
||||
(if (not len)
|
||||
(progn
|
||||
(harness-log "PROTOCOL ERROR: Invalid header ~s. Attempting resync..." length-buffer)
|
||||
:error)
|
||||
(let ((msg-buffer (make-string len)))
|
||||
(read-sequence msg-buffer stream)
|
||||
(let ((*read-eval* nil)
|
||||
(*print-pretty* nil))
|
||||
(handler-case
|
||||
(let ((msg (read-from-string msg-buffer)))
|
||||
(validate-communication-protocol-schema msg)
|
||||
msg)
|
||||
(error (c)
|
||||
(harness-log "PROTOCOL PARSE ERROR: ~a in ~s" c msg-buffer)
|
||||
:error))))))))))
|
||||
(error (c)
|
||||
(harness-log "PROTOCOL READ ERROR: ~a" c)
|
||||
:error))))
|
||||
|
||||
(defun make-hello-message (version)
|
||||
"Constructs the standard HELLO handshake message."
|
||||
(list :TYPE :EVENT
|
||||
:PAYLOAD (list :ACTION :handshake
|
||||
:VERSION version
|
||||
:CAPABILITIES '(:AUTH :SWANK :ORG-AST))))
|
||||
|
||||
(defun sanitize-protocol-message (msg)
|
||||
"Recursively strips non-serializable objects from a protocol plist."
|
||||
(if (and msg (listp msg))
|
||||
(let ((clean nil))
|
||||
(loop for (k v) on msg by #'cddr
|
||||
do (unless (member k '(:reply-stream :socket :stream))
|
||||
(push k clean)
|
||||
(push (if (listp v) (sanitize-protocol-message v) v) clean)))
|
||||
(nreverse clean))
|
||||
msg))
|
||||
|
||||
(defun frame-message (msg)
|
||||
"Serializes a message plist and prefixes it with a 6-character hex length."
|
||||
(let* ((sanitized (sanitize-protocol-message msg))
|
||||
(payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized)))
|
||||
(len (length payload)))
|
||||
(format nil "~6,'0x~a" len payload)))
|
||||
@@ -1,109 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun bouncer-scan-secrets (text)
|
||||
"Returns the name of the secret found in TEXT, or NIL if clean."
|
||||
(when (and text (stringp text))
|
||||
(let ((found-secret nil))
|
||||
(maphash (lambda (key val)
|
||||
(when (and val (stringp val) (> (length val) 5))
|
||||
(when (search val text)
|
||||
(setf found-secret key))))
|
||||
opencortex::*vault-memory*)
|
||||
found-secret)))
|
||||
|
||||
(defun bouncer-check-network-exfil (cmd)
|
||||
"Returns T if the command appears to target an unwhitelisted external host."
|
||||
(when (and cmd (stringp cmd))
|
||||
;; Basic check for common data exfiltration tools being used with IPs/URLs
|
||||
(let ((network-whitelist '("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")))
|
||||
(when (cl-ppcre:scan "(http|https|ftp)://([\\w\\.-]+)" cmd)
|
||||
(multiple-value-bind (match regs)
|
||||
(cl-ppcre:scan-to-strings "(http|https|ftp)://([\\w\\.-]+)" cmd)
|
||||
(declare (ignore match))
|
||||
(let ((domain (aref regs 1)))
|
||||
(not (some (lambda (safe) (search safe domain)) network-whitelist))))))))
|
||||
|
||||
(defun bouncer-check (action context)
|
||||
"The 5-Vector security gate. Blocks or queues actions based on risk."
|
||||
(let* ((target (getf action :target))
|
||||
(payload (getf action :payload))
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
;; Extract cmd from direct shell or tool-mediated shell call
|
||||
(cmd (or (getf payload :cmd)
|
||||
(when (and (eq target :tool) (equal (getf payload :tool) "shell"))
|
||||
(getf (getf payload :args) :cmd))))
|
||||
(approved (getf action :approved)))
|
||||
|
||||
(cond
|
||||
;; 0. Bypass for already approved actions
|
||||
(approved action)
|
||||
|
||||
;; 1. Secret Exposure Vector (Hard Block)
|
||||
((and text (bouncer-scan-secrets text))
|
||||
(let ((secret-name (bouncer-scan-secrets text)))
|
||||
(harness-log "SECURITY VIOLATION: Blocked leak of secret ~a" secret-name)
|
||||
`(:type :log :payload (:level :error :text ,(format nil "Action blocked: Potential exposure of ~a" secret-name)))))
|
||||
|
||||
;; 2. Network Exfiltration Vector (Authorization Required)
|
||||
((and (or (eq target :shell)
|
||||
(and (eq target :tool) (equal (getf payload :tool) "shell")))
|
||||
(bouncer-check-network-exfil cmd))
|
||||
(harness-log "SECURITY WARNING: External network call detected. Queuing for approval.")
|
||||
`(:type :EVENT :payload (:sensor :approval-required :action ,action)))
|
||||
|
||||
;; 3. High-Impact Target Vector (Authorization Required)
|
||||
((or (member target '(:shell))
|
||||
(and (eq target :tool) (member (getf payload :tool) '("shell" "repair-file") :test #'string=))
|
||||
(and (eq target :EMACS) (eq (getf payload :action) :eval)))
|
||||
(harness-log "SECURITY: High-impact action ~a requires approval." (or (getf payload :tool) target))
|
||||
`(:type :EVENT :payload (:sensor :approval-required :action ,action)))
|
||||
|
||||
;; 4. Default Pass
|
||||
(t action))))
|
||||
|
||||
(defun bouncer-process-approvals ()
|
||||
"Scans the object store for APPROVED flight plans and re-injects their actions."
|
||||
(let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED"))
|
||||
(found-any nil))
|
||||
(dolist (node approved-nodes)
|
||||
(let* ((tags (getf (org-object-attributes node) :TAGS))
|
||||
(action-str (getf (org-object-attributes node) :ACTION)))
|
||||
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str)
|
||||
(harness-log "BOUNCER: Found approved flight plan ~a. Re-injecting..." (org-object-id node))
|
||||
(let ((action (ignore-errors (read-from-string action-str))))
|
||||
(when action
|
||||
;; Mark as approved to bypass the gate
|
||||
(setf (getf action :approved) t)
|
||||
(inject-stimulus action)
|
||||
;; Mark as DONE
|
||||
(setf (getf (org-object-attributes node) :TODO) "DONE")
|
||||
(setq found-any t))))))
|
||||
found-any))
|
||||
|
||||
(defun bouncer-deterministic-gate (action context)
|
||||
"Main gate for the bouncer skill."
|
||||
(let* ((payload (getf context :payload))
|
||||
(sensor (getf payload :sensor)))
|
||||
(case sensor
|
||||
(:approval-required
|
||||
(let* ((blocked-action (getf payload :action))
|
||||
(id (org-id-new)))
|
||||
(harness-log "BOUNCER: Creating flight plan node...")
|
||||
;; Create the node in Emacs (or inbox)
|
||||
(list :type :REQUEST :target :EMACS :action :insert-node
|
||||
:id id :attributes `(:TITLE "Flight Plan: High-Risk Action"
|
||||
:TODO "PLAN"
|
||||
:TAGS ("FLIGHT_PLAN")
|
||||
:ACTION ,(format nil "~s" blocked-action)))))
|
||||
(:heartbeat
|
||||
;; Periodically check for approvals
|
||||
(bouncer-process-approvals)
|
||||
(if action (bouncer-check action context) action))
|
||||
(otherwise
|
||||
(if action (bouncer-check action context) action)))))
|
||||
|
||||
(defskill :skill-bouncer
|
||||
:priority 150
|
||||
:trigger (lambda (ctx) t) ;; Bouncer evaluates all actions deterministically
|
||||
:probabilistic nil
|
||||
:deterministic #'bouncer-deterministic-gate)
|
||||
@@ -1,81 +0,0 @@
|
||||
(defvar *cli-port* 9105)
|
||||
(defvar *cli-server-socket* nil)
|
||||
(defvar *cli-server-thread* nil)
|
||||
|
||||
(defun execute-cli-action (action context)
|
||||
"Sends a framed message back to the connected CLI client."
|
||||
(let* ((payload (proto-get action :PAYLOAD))
|
||||
(meta (getf context :meta))
|
||||
(stream (getf meta :reply-stream)))
|
||||
(handler-case
|
||||
(if (and stream (open-stream-p stream))
|
||||
(progn
|
||||
(format stream "~a" (frame-message action))
|
||||
(finish-output stream)
|
||||
(format stream "~a" (frame-message '(:TYPE :STATUS :SCRIBE :IDLE :GARDENER :SLEEPING)))
|
||||
(finish-output stream))
|
||||
(harness-log "CLI ERROR: No active or open reply stream for signal."))
|
||||
(error (c) (harness-log "CLI ACTUATOR ERROR: ~a" c)))))
|
||||
|
||||
(defun handle-cli-slash-command (cmd stream)
|
||||
(cond
|
||||
((string= cmd "/exit") (return-from handle-cli-slash-command :exit))
|
||||
(t (format stream "~a" (frame-message (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (format nil "Unknown command: ~a" cmd))))))))
|
||||
|
||||
(defun handle-cli-client (stream)
|
||||
"Reads framed messages from a CLI client and injects them as stimuli."
|
||||
(harness-log "CLI: Client connected.")
|
||||
(handler-case
|
||||
(progn
|
||||
;; 1. Send Handshake
|
||||
(format stream "~a" (frame-message (make-hello-message "0.1.0")))
|
||||
(finish-output stream)
|
||||
(format stream "~a" (frame-message '(:TYPE :STATUS :SCRIBE :IDLE :GARDENER :SLEEPING)))
|
||||
(finish-output stream)
|
||||
|
||||
;; 2. Communication Loop
|
||||
(loop
|
||||
(let ((msg (read-framed-message stream)))
|
||||
(cond ((eq msg :eof) (return))
|
||||
((eq msg :error) (return))
|
||||
(t (let* ((payload (proto-get msg :payload))
|
||||
(text (proto-get payload :text))
|
||||
(meta (proto-get msg :meta)))
|
||||
(if (and text (stringp text) (char= (char text 0) #\/))
|
||||
(when (eq (handle-cli-slash-command text stream) :exit) (return))
|
||||
(progn
|
||||
;; Default meta if missing
|
||||
(unless meta
|
||||
(setf (getf msg :meta) (list :SOURCE :CLI :SESSION-ID "default")))
|
||||
(harness-log "CLI: Received input -> ~s" msg)
|
||||
(inject-stimulus msg :stream stream)))))))))
|
||||
(error (c) (harness-log "CLI CLIENT DISCONNECT: ~a" c)))
|
||||
(harness-log "CLI: Client disconnected."))
|
||||
|
||||
(defun start-cli-gateway (&optional (port *cli-port*))
|
||||
"Starts the TCP listener for local CLI clients."
|
||||
(setf *cli-server-socket* (usocket:socket-listen "0.0.0.0" port :reuse-address t))
|
||||
(setf *cli-server-thread*
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(unwind-protect
|
||||
(loop
|
||||
(let* ((socket (usocket:socket-accept *cli-server-socket*))
|
||||
(stream (usocket:socket-stream socket)))
|
||||
(bt:make-thread (lambda ()
|
||||
(unwind-protect (handle-cli-client stream)
|
||||
(usocket:socket-close socket)))
|
||||
:name "opencortex-cli-client-handler")))
|
||||
(usocket:socket-close *cli-server-socket*)))
|
||||
:name "opencortex-cli-gateway"))
|
||||
(harness-log "CLI: Gateway listening on port ~a" port))
|
||||
|
||||
(register-actuator :CLI #'execute-cli-action)
|
||||
|
||||
(defskill :skill-gateway-cli
|
||||
:priority 200
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
|
||||
(start-cli-gateway)
|
||||
@@ -1,82 +0,0 @@
|
||||
(defun vault-get-secret (provider &key type)
|
||||
"Retrieves a secret (api-key or session) for a provider.")
|
||||
|
||||
(defun vault-set-secret (provider secret &key type)
|
||||
"Securely stores a secret and triggers a Merkle snapshot.")
|
||||
|
||||
|
||||
|
||||
(defvar opencortex::*vault-memory* (make-hash-table :test 'equal)
|
||||
"In-memory cache of sensitive credentials.")
|
||||
|
||||
(defun vault-mask-string (str)
|
||||
"Returns a masked version of a sensitive string."
|
||||
(if (and str (> (length str) 8))
|
||||
(format nil "~a...~a" (subseq str 0 4) (subseq str (- (length str) 4)))
|
||||
"[REDACTED]"))
|
||||
|
||||
(defun vault-get-secret (provider &key (type :api-key))
|
||||
"Retrieves a credential. Type can be :api-key or :session."
|
||||
(let* ((key (format nil "~a-~a" provider type))
|
||||
(val (gethash key opencortex::*vault-memory*)))
|
||||
(if val
|
||||
val
|
||||
;; Fallback to environment
|
||||
(let ((env-var (case provider
|
||||
((:gemini :gemini-api) "GEMINI_API_KEY")
|
||||
(:openai "OPENAI_API_KEY")
|
||||
(:anthropic "ANTHROPIC_API_KEY")
|
||||
(:groq "GROQ_API_KEY")
|
||||
(:openrouter "OPENROUTER_API_KEY")
|
||||
(:telegram "TELEGRAM_BOT_TOKEN")
|
||||
(:signal "SIGNAL_ACCOUNT_NUMBER")
|
||||
(:matrix-homeserver "MATRIX_HOMESERVER")
|
||||
(:matrix-token "MATRIX_ACCESS_TOKEN")
|
||||
(t nil))))
|
||||
(when (and env-var (eq type :api-key))
|
||||
(uiop:getenv env-var))))))
|
||||
|
||||
(defun vault-set-secret (provider secret &key (type :api-key))
|
||||
"Securely stores a secret and triggers a Merkle snapshot."
|
||||
(let ((key (format nil "~a-~a" provider type)))
|
||||
(setf (gethash key opencortex::*vault-memory*) secret)
|
||||
(harness-log "VAULT - Updated ~a for ~a. Triggering Merkle snapshot..." type provider)
|
||||
(snapshot-memory)
|
||||
t))
|
||||
|
||||
(defun vault-onboard-gemini-web ()
|
||||
"Instructions for the Autonomous Cookie Handshake."
|
||||
(harness-log "--- GEMINI WEB ONBOARDING ---")
|
||||
(harness-log "1. Visit gemini.google.com")
|
||||
(harness-log "2. Run the 'Get Gemini Cookies' Bookmarklet.")
|
||||
(harness-log " CODE: javascript:(function(){const c=document.cookie.split('; ').reduce((r,v)=>{const [n,val]=v.split('=');r[n]=val;return r},{});const target=['__Secure-1PSID','__Secure-1PSIDTS'];const out=target.map(n=>({name:n,value:c[n]}));prompt('Copy JSON:',JSON.stringify(out));})();")
|
||||
(harness-log "PLATFORM GUIDE: Chrome/Firefox/Safari all support Bookmarklets via 'Add Page' or 'New Bookmark'.")
|
||||
t)
|
||||
|
||||
(progn
|
||||
(defskill :skill-credentials-vault
|
||||
:priority 200 ; High priority, foundational
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :onboarding-request))
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action ctx)
|
||||
(vault-onboard-gemini-web)
|
||||
action)))
|
||||
|
||||
#|
|
||||
(defpackage :opencortex-vault-tests
|
||||
(:use :cl :fiveam :opencortex))
|
||||
(in-package :opencortex-vault-tests)
|
||||
|
||||
(def-suite vault-suite :description "Tests for the Credentials Vault.")
|
||||
(in-suite vault-suite)
|
||||
|
||||
(test test-masking
|
||||
(is (equal "sk-t...-key" (opencortex::vault-mask-string "sk-test-key")))
|
||||
(is (equal "[REDACTED]" (opencortex::vault-mask-string "short"))))
|
||||
|
||||
(test test-vault-persistence
|
||||
"Verify that setting a secret triggers a snapshot (mock check)."
|
||||
(let ((old-version (opencortex::org-object-version (gethash "root" *memory*))))
|
||||
(opencortex:vault-set-secret :test "secret-val")
|
||||
(is (> (opencortex::org-object-version (gethash "root" *memory*)) old-version))))
|
||||
|#
|
||||
@@ -1,68 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *gardener-last-audit* 0
|
||||
"The universal-time of the last full Memex audit.")
|
||||
|
||||
(defun gardener-find-broken-links ()
|
||||
"Returns a list of broken ID links found in the Memex."
|
||||
(let ((broken nil))
|
||||
(maphash (lambda (id obj)
|
||||
(let ((content (org-object-content obj)))
|
||||
(when content
|
||||
(cl-ppcre:do-register-groups (target-id) ("id:([A-Za-z0-9-]+)" content)
|
||||
(unless (lookup-object target-id)
|
||||
(push (list :source id :broken-target target-id) broken))))))
|
||||
*memory*)
|
||||
broken))
|
||||
|
||||
(defun gardener-find-orphans ()
|
||||
"Returns a list of IDs for headlines that are structurally isolated."
|
||||
(let ((inbound (make-hash-table :test 'equal))
|
||||
(outbound (make-hash-table :test 'equal))
|
||||
(orphans nil))
|
||||
;; 1. Map all connections
|
||||
(maphash (lambda (id obj)
|
||||
(let ((content (org-object-content obj)))
|
||||
(when content
|
||||
(cl-ppcre:do-register-groups (target-id) ("id:([A-Za-z0-9-]+)" content)
|
||||
(setf (gethash id outbound) t)
|
||||
(setf (gethash target-id inbound) t)))))
|
||||
*memory*)
|
||||
;; 2. Identify nodes with zero connections
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore obj))
|
||||
(unless (or (gethash id inbound) (gethash id outbound))
|
||||
(push id orphans)))
|
||||
*memory*)
|
||||
orphans))
|
||||
|
||||
(defun gardener-deterministic-gate (action context)
|
||||
"Main gate for the Gardener skill. Audits graph integrity."
|
||||
(declare (ignore action context))
|
||||
(let ((broken (gardener-find-broken-links))
|
||||
(orphans (gardener-find-orphans)))
|
||||
|
||||
(when (or broken orphans)
|
||||
(harness-log "GARDENER: Audit found ~a broken links and ~a orphans."
|
||||
(length broken) (length orphans))
|
||||
|
||||
(dolist (link broken)
|
||||
(harness-log " [BROKEN LINK] Node ~a -> ~a" (getf link :source) (getf link :broken-target)))
|
||||
|
||||
(dolist (orphan orphans)
|
||||
(harness-log " [ORPHAN] Node ~a is isolated." orphan)))
|
||||
|
||||
(setf *gardener-last-audit* (get-universal-time))
|
||||
;; Return a log to stop the loop
|
||||
(list :type :LOG :payload (list :text "Gardener audit complete."))))
|
||||
|
||||
(defskill :skill-gardener
|
||||
:priority 40
|
||||
:trigger (lambda (ctx)
|
||||
(let* ((payload (getf ctx :payload))
|
||||
(sensor (getf payload :sensor)))
|
||||
(and (eq sensor :heartbeat)
|
||||
;; Only audit once per day
|
||||
(> (- (get-universal-time) *gardener-last-audit*) 86400))))
|
||||
:probabilistic nil
|
||||
:deterministic #'gardener-deterministic-gate)
|
||||
@@ -1,28 +0,0 @@
|
||||
(defun memory-org-to-json (source)
|
||||
"Converts Org-mode source to JSON AST."
|
||||
(declare (ignore source))
|
||||
"")
|
||||
|
||||
(defun memory-json-to-org (ast)
|
||||
"Converts JSON AST back to Org-mode text."
|
||||
(declare (ignore ast))
|
||||
"")
|
||||
|
||||
(defun memory-normalize-ast (ast)
|
||||
"Recursively ensures ID uniqueness across the AST."
|
||||
(declare (ignore ast))
|
||||
nil)
|
||||
|
||||
(defun make-memory-node (headline &key content properties children)
|
||||
"Constructor for a normalized Org node alist."
|
||||
(declare (ignore headline))
|
||||
(list :TYPE :HEADLINE
|
||||
:PROPERTIES (or properties nil)
|
||||
:CONTENT content
|
||||
:CONTENTS children))
|
||||
|
||||
(defskill :skill-homoiconic-memory
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
@@ -1,231 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun lisp-validator-check-structural (code-string)
|
||||
"Checks for balanced parens, brackets, and terminated strings.
|
||||
Returns (VALUES t nil) if clean, or (VALUES nil reason-string line col)."
|
||||
(let ((stack nil)
|
||||
(in-string nil)
|
||||
(escaped nil)
|
||||
(line 1)
|
||||
(col 0)
|
||||
(last-open-line 1)
|
||||
(last-open-col 0))
|
||||
(dotimes (i (length code-string)
|
||||
(if (null stack)
|
||||
(values t nil nil nil)
|
||||
(values nil (format nil "Unbalanced '~a' opened at line ~a, col ~a"
|
||||
(caar stack) last-open-line last-open-col)
|
||||
last-open-line last-open-col)))
|
||||
(let ((ch (char code-string i)))
|
||||
(cond (escaped (setf escaped nil))
|
||||
((char= ch #\\) (setf escaped t))
|
||||
(in-string
|
||||
(when (char= ch #\") (setf in-string nil)))
|
||||
((char= ch #\;)
|
||||
;; Skip to end of line
|
||||
(loop while (and (< i (1- (length code-string)))
|
||||
(not (char= (char code-string (1+ i)) #\Newline)))
|
||||
do (incf i))
|
||||
(incf line) (setf col 0))
|
||||
((char= ch #\")
|
||||
(setf in-string t))
|
||||
((member ch '(#\( #\[))
|
||||
(push (list (string ch) line col) stack)
|
||||
(setf last-open-line line last-open-col col))
|
||||
((char= ch #\))
|
||||
(cond ((null stack)
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Unexpected ')' at line ~a, col ~a" line col) line col)))
|
||||
((string= (caar stack) "[")
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Mismatched ']' expected at line ~a, col ~a" line col) line col)))
|
||||
(t (pop stack))))
|
||||
((char= ch #\])
|
||||
(cond ((null stack)
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Unexpected ']' at line ~a, col ~a" line col) line col)))
|
||||
((string= (caar stack) "(")
|
||||
(return-from lisp-validator-check-structural
|
||||
(values nil (format nil "Mismatched ')' expected at line ~a, col ~a" line col) line col)))
|
||||
(t (pop stack))))
|
||||
((char= ch #\Newline)
|
||||
(incf line) (setf col 0)))
|
||||
(unless (char= ch #\Newline) (incf col))))))
|
||||
|
||||
(defun lisp-validator-check-syntactic (code-string)
|
||||
"Checks if the code can be read by SBCL with *read-eval* nil.
|
||||
Returns (VALUES t nil) if clean, or (VALUES nil error-message line col)."
|
||||
(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 nil nil))
|
||||
(error (c)
|
||||
(let ((msg (format nil "~a" c)))
|
||||
(values nil msg nil nil)))))
|
||||
|
||||
(defparameter *lisp-validator-whitelist*
|
||||
'(;; Math & Logic
|
||||
+ - * / = < > <= >= 1+ 1- min max mod abs floor ceiling round
|
||||
and or not null eq eql equal string= string-equal char= char-equal
|
||||
;; List Manipulation
|
||||
list cons car cdr cadr cddr cdar caar caddr cdddr append mapcar remove-if remove-if-not
|
||||
length reverse sort nth nthcdr push pop last butlast subseq
|
||||
;; Plists, Alists, and Hash Tables
|
||||
getf gethash assoc acons pairlis rassoc
|
||||
;; Control Flow
|
||||
let let* if cond when unless case typecase prog1 progn
|
||||
;; Strings
|
||||
format concatenate string-downcase string-upcase search subseq replace
|
||||
;; Type predicates
|
||||
stringp numberp integerp listp symbolp keywordp null
|
||||
;; Kernel safe symbols
|
||||
opencortex::harness-log
|
||||
opencortex::snapshot-memory opencortex::rollback-memory
|
||||
opencortex::lookup-object opencortex::list-objects-by-type
|
||||
opencortex::ingest-ast opencortex::find-headline-missing-id
|
||||
opencortex::context-query-store opencortex::context-get-active-projects
|
||||
opencortex::context-get-recent-completed-tasks opencortex::context-list-all-skills
|
||||
opencortex::context-get-system-logs opencortex::context-assemble-global-awareness
|
||||
opencortex::org-object-id opencortex::org-object-type opencortex::org-object-attributes
|
||||
opencortex::org-object-content opencortex::org-object-parent-id
|
||||
opencortex::org-object-children opencortex::org-object-version
|
||||
opencortex::org-object-last-sync opencortex::org-object-hash
|
||||
opencortex::org-object-vector
|
||||
;; Essential macros and special operators
|
||||
declare ignore quote function lambda defun defvar defparameter defmacro
|
||||
;; Safe I/O
|
||||
with-open-file write-string read-line
|
||||
;; Package introspection
|
||||
find-package make-package in-package do-external-symbols find-symbol
|
||||
;; Safe system interaction
|
||||
uiop:run-program uiop:getenv uiop:merge-pathnames* uiop:file-exists-p
|
||||
uiop:directory-exists-p uiop:read-file-string uiop:split-string
|
||||
;; Time
|
||||
get-universal-time get-internal-real-time sleep
|
||||
;; Equality
|
||||
equalp = equal eq eql))
|
||||
"Static whitelist of symbols permitted in the Lisp Validator sandbox."
|
||||
|
||||
(defvar *lisp-validator-registry* nil
|
||||
"List of dynamically registered safe symbols.")
|
||||
|
||||
(defun lisp-validator-register (symbols)
|
||||
"Adds symbols to the global validator registry."
|
||||
(setf *lisp-validator-registry*
|
||||
(append *lisp-validator-registry*
|
||||
(if (listp symbols) symbols (list symbols))))
|
||||
(harness-log "LISP VALIDATOR: Registered ~a new safe symbols."
|
||||
(length (if (listp symbols) symbols (list symbols)))))
|
||||
|
||||
(defun lisp-validator-is-safe (symbol)
|
||||
"Checks if a symbol is in the static whitelist or the dynamic registry."
|
||||
(or (member symbol *lisp-validator-whitelist* :test #'string-equal)
|
||||
(member symbol *lisp-validator-registry* :test #'string-equal)))
|
||||
|
||||
(defun lisp-validator-ast-walk (form)
|
||||
"Recursively walks the Lisp AST. Returns T if safe, NIL if unsafe."
|
||||
(cond
|
||||
;; Self-evaluating objects are safe.
|
||||
((or (stringp form) (numberp form) (keywordp form) (characterp form)) t)
|
||||
;; Symbols used as variables (in non-function position)
|
||||
((symbolp form) (lisp-validator-is-safe form))
|
||||
;; Lists represent function calls or special forms.
|
||||
((listp form)
|
||||
(let ((head (car form)))
|
||||
(cond
|
||||
((eq head 'quote) t)
|
||||
((not (symbolp head)) nil)
|
||||
((lisp-validator-is-safe head)
|
||||
(every #'lisp-validator-ast-walk (cdr form)))
|
||||
(t
|
||||
(harness-log "LISP VALIDATOR: Blocked call to non-whitelisted function ~a" head)
|
||||
nil))))
|
||||
(t nil)))
|
||||
|
||||
(defun lisp-validator-check-semantic (code-string)
|
||||
"Checks if all symbols in CODE-STRING are whitelisted.
|
||||
Returns (VALUES t nil) if clean, or (VALUES nil reason-string nil nil)."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof)
|
||||
until (eq form :eof)
|
||||
do (unless (lisp-validator-ast-walk form)
|
||||
(return-from lisp-validator-check-semantic
|
||||
(values nil "Code contains non-whitelisted symbols." nil nil)))))
|
||||
(values t nil nil nil))
|
||||
(error (c)
|
||||
(values nil (format nil "Semantic check failed: ~a" c) nil nil))))
|
||||
|
||||
(defun lisp-validator-validate (code-string &key strict)
|
||||
"Validates Lisp code through structural, syntactic, and optional semantic checks.
|
||||
Returns a plist:
|
||||
(:status :success :checks (:structural t :syntactic t :semantic t))
|
||||
or
|
||||
(:status :error :failed <check-key> :reason <string> :line <n> :col <n>)
|
||||
|
||||
When STRICT is non-nil, the semantic whitelist check is enforced.
|
||||
When STRICT is nil, semantic check is skipped for general validation."
|
||||
(let ((structural-ok nil) (syntactic-ok nil) (semantic-ok nil)
|
||||
(reason nil) (line nil) (col nil))
|
||||
;; Phase 1: Structural
|
||||
(multiple-value-setq (structural-ok reason line col)
|
||||
(lisp-validator-check-structural code-string))
|
||||
(unless structural-ok
|
||||
(return-from lisp-validator-validate
|
||||
(list :status :error :failed :structural :reason reason :line line :col col)))
|
||||
;; Phase 2: Syntactic
|
||||
(multiple-value-setq (syntactic-ok reason line col)
|
||||
(lisp-validator-check-syntactic code-string))
|
||||
(unless syntactic-ok
|
||||
(return-from lisp-validator-validate
|
||||
(list :status :error :failed :syntactic :reason reason :line line :col col)))
|
||||
;; Phase 3: Semantic (only when strict)
|
||||
(when strict
|
||||
(multiple-value-setq (semantic-ok reason line col)
|
||||
(lisp-validator-check-semantic code-string))
|
||||
(unless semantic-ok
|
||||
(return-from lisp-validator-validate
|
||||
(list :status :error :failed :semantic :reason reason :line line :col col))))
|
||||
;; All clear
|
||||
(list :status :success
|
||||
:checks (list :structural t :syntactic t :semantic (or (not strict) semantic-ok)))))
|
||||
|
||||
(def-cognitive-tool :validate-lisp
|
||||
"Deterministically validates Lisp code for structural, syntactic, and semantic correctness.
|
||||
Use this BEFORE declaring any Lisp code edit complete."
|
||||
((:code :type :string :description "The Lisp code string to validate.")
|
||||
(:strict :type :boolean :description "If non-nil, enforces the semantic whitelist."))
|
||||
:body (lambda (args)
|
||||
(let ((code (getf args :code))
|
||||
(strict (getf args :strict)))
|
||||
(if (and code (stringp code))
|
||||
(lisp-validator-validate code :strict strict)
|
||||
(list :status :error :reason "Missing :code argument.")))))
|
||||
|
||||
(defskill :skill-lisp-validator
|
||||
:priority 900
|
||||
:trigger (lambda (ctx)
|
||||
;; Trigger on any eval or shell action, or when validation is explicitly requested
|
||||
(let ((candidate (getf ctx :approved-action)))
|
||||
(when candidate
|
||||
(let ((payload (getf candidate :payload)))
|
||||
(member (getf payload :action) '(:eval :shell))))))
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action context)
|
||||
(declare (ignore context))
|
||||
(let ((payload (getf action :payload)))
|
||||
(if (eq (getf payload :action) :eval)
|
||||
(let* ((code (getf payload :code))
|
||||
(result (lisp-validator-validate code :strict t)))
|
||||
(if (eq (getf result :status) :error)
|
||||
(progn
|
||||
(harness-log "LISP VALIDATOR: Blocked unsafe :eval action. ~a"
|
||||
(getf result :reason))
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text (format nil "LISP VALIDATOR: Blocked unsafe eval. ~a"
|
||||
(getf result :reason)))))
|
||||
action))
|
||||
action))))
|
||||
@@ -1,33 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun llama-inference (prompt system-prompt &key (model "local-model"))
|
||||
"Sends a completion request to the local llama.cpp server."
|
||||
(let ((endpoint (uiop:getenv "LLAMACPP_ENDPOINT")))
|
||||
(unless endpoint
|
||||
(harness-log "LLAMA ERROR: LLAMACPP_ENDPOINT not set in environment.")
|
||||
(return-from llama-inference (list :error "LLAMACPP_ENDPOINT_MISSING")))
|
||||
|
||||
(handler-case
|
||||
(let* ((full-prompt (format nil "System: ~a~%User: ~a~%Assistant:" system-prompt prompt))
|
||||
(payload (cl-json:encode-json-to-string
|
||||
`((:prompt . ,full-prompt)
|
||||
(:n_predict . 1024)
|
||||
(:stop . ("User:" "System:")))))
|
||||
(response (dex:post (format nil "~a/completion" endpoint)
|
||||
:content payload
|
||||
:headers '(("Content-Type" . "application/json"))))
|
||||
(data (cl-json:decode-json-from-string response)))
|
||||
(cdr (assoc :content data)))
|
||||
(error (c)
|
||||
(harness-log "LLAMA ERROR: Connection failed -> ~a" c)
|
||||
(list :error (format nil "~a" c))))))
|
||||
|
||||
(progn
|
||||
(register-probabilistic-backend :llama #'llama-inference)
|
||||
(harness-log "LLAMA: Local backend registered and active."))
|
||||
|
||||
(defskill :skill-llama-backend
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil) ; Pure infrastructure skill
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
@@ -1,110 +0,0 @@
|
||||
(defun get-nested (alist &rest keys)
|
||||
"Recursively extracts nested values from an alist, handling both objects and arrays."
|
||||
(let ((val alist))
|
||||
(dolist (k keys)
|
||||
;; Descend into arrays (cl-json style: ((key . val)) or ( ( (key . val) ) ))
|
||||
(loop while (and (listp val) (listp (car val)) (not (keywordp (caar val))))
|
||||
do (setf val (car val)))
|
||||
(let ((pair (or (assoc k val)
|
||||
(assoc (intern (string-upcase (string k)) :keyword) val)
|
||||
(assoc (intern (string-downcase (string k)) :keyword) val))))
|
||||
(if pair
|
||||
(setf val (cdr pair))
|
||||
(return-from get-nested nil))))
|
||||
val))
|
||||
|
||||
(defun execute-llm-request (prompt system-prompt &key provider model)
|
||||
"Unified entry point for all LLM providers. Respects the global cascade."
|
||||
(let* ((active-provider (or provider (car opencortex::*provider-cascade*) :openrouter))
|
||||
(api-key (vault-get-secret active-provider :type :api-key))
|
||||
(full-prompt (format nil "~a~%~%Prompt: ~a" system-prompt prompt)))
|
||||
|
||||
(harness-log "PROBABILISTIC ENGINE: Requesting ~a (Model: ~s)"
|
||||
active-provider (or model "default"))
|
||||
|
||||
;; If the specifically requested provider has no key, try falling back to the cascade
|
||||
(when (or (null api-key) (string= api-key ""))
|
||||
(harness-log "GATEWAY: Provider ~a has no key. Cascade fallback would trigger here." active-provider)
|
||||
(return-from execute-llm-request (list :status :error :message "API Key missing.")))
|
||||
|
||||
(case active-provider
|
||||
(:gemini-web
|
||||
(let ((res (uiop:symbol-call :opencortex.skills.org-skill-web-research :ask-gemini-web full-prompt)))
|
||||
(if res (list :status :success :content res) (list :status :error :message "Web Research Failure"))))
|
||||
|
||||
(:ollama
|
||||
(let* ((host (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||
(url (format nil "http://~a/api/generate" host))
|
||||
(body (cl-json:encode-json-to-string `((model . ,(or model "llama3")) (prompt . ,full-prompt) (stream . :false)))))
|
||||
(handler-case
|
||||
(progn
|
||||
(harness-log "LLM DEBUG: Requesting Ollama...")
|
||||
(let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 60))
|
||||
(json (cl-json:decode-json-from-string response)))
|
||||
(list :status :success :content (cdr (assoc :response json)))))
|
||||
(error (c) (list :status :error :message (format nil "Ollama Failure: ~a" c))))))
|
||||
|
||||
(t ;; Cloud Providers (Anthropic, Gemini API, Groq, OpenAI, OpenRouter)
|
||||
(let* ((endpoint (case active-provider
|
||||
(:anthropic "https://api.anthropic.com/v1/messages")
|
||||
(:gemini-api (format nil "https://generativelanguage.googleapis.com/v1/models/~a:generateContent" (or model "gemini-1.5-flash-latest")))
|
||||
(:groq "https://api.groq.com/openai/v1/chat/completions")
|
||||
(:openai "https://api.openai.com/v1/chat/completions")
|
||||
(:openrouter "https://openrouter.ai/api/v1/chat/completions")))
|
||||
(headers (case active-provider
|
||||
(:anthropic `(("Content-Type" . "application/json") ("x-api-key" . ,api-key) ("anthropic-version" . "2023-06-01")))
|
||||
(:gemini-api `(("Content-Type" . "application/json") ("x-goog-api-key" . ,api-key)))
|
||||
(:openrouter `(("Content-Type" . "application/json") ("Authorization" . ,(format nil "Bearer ~a" api-key))
|
||||
("HTTP-Referer" . "https://github.com/amr/opencortex") ("X-Title" . "opencortex Autonomous Kernel")))
|
||||
(t `(("Content-Type" . "application/json") ("Authorization" . ,(format nil "Bearer ~a" api-key))))))
|
||||
(body (case active-provider
|
||||
(:anthropic (cl-json:encode-json-to-string `((model . ,(or model "claude-3-5-sonnet-20240620")) (max_tokens . 4096) (system . ,system-prompt) (messages . (( (role . "user") (content . ,prompt) ))))))
|
||||
(:gemini-api (cl-json:encode-json-to-string `((contents . (((parts . (((text . ,full-prompt))))))))))
|
||||
(t (cl-json:encode-json-to-string `((model . ,(or model (case active-provider (:groq "llama-3.3-70b-versatile") (t "google/gemini-2.0-flash-001"))))
|
||||
(messages . (( (role . "system") (content . ,system-prompt) ) ( (role . "user") (content . ,prompt) )))))))))
|
||||
(handler-case
|
||||
(progn
|
||||
(harness-log "LLM DEBUG: Requesting ~a..." active-provider)
|
||||
(let* ((response (dex:post endpoint :headers headers :content body :connect-timeout 10 :read-timeout 30))
|
||||
(json (cl-json:decode-json-from-string response)))
|
||||
(let ((content (case active-provider
|
||||
(:anthropic (get-nested json :content :text))
|
||||
(:gemini-api (get-nested json :candidates :parts :text))
|
||||
(t (get-nested json :choices :message :content)))))
|
||||
(if content
|
||||
(list :status :success :content content)
|
||||
(list :status :error :message (format nil "Failed to parse ~a response structure." active-provider))))))
|
||||
(error (c) (list :status :error :message (format nil "LLM Gateway Failure (~a): ~a" active-provider c)))))))))
|
||||
|
||||
;; Initialize Cascade
|
||||
(let* ((env-cascade (uiop:getenv "PROVIDER_CASCADE"))
|
||||
(default-list '(:openrouter :openai :anthropic :groq :gemini-api :ollama))
|
||||
(final-list (if (and env-cascade (not (string= env-cascade "")))
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword))
|
||||
(uiop:split-string env-cascade :separator '(#\,)))
|
||||
default-list)))
|
||||
(setf opencortex::*provider-cascade* final-list)
|
||||
(opencortex:harness-log "PROBABILISTIC: Neural Cascade Initialized -> ~a" final-list))
|
||||
|
||||
;; Register Providers
|
||||
(dolist (p '(:anthropic :gemini-api :gemini-web :groq :ollama :openrouter :openai))
|
||||
(opencortex:register-probabilistic-backend p (lambda (prompt system-prompt &key model)
|
||||
(execute-llm-request prompt system-prompt :provider p :model model))))
|
||||
|
||||
(def-cognitive-tool :ask-llm
|
||||
"Queries an LLM provider via the unified gateway."
|
||||
((:prompt :type :string :description "The user prompt.")
|
||||
(:system-prompt :type :string :description "The system instructions.")
|
||||
(:provider :type :keyword :description "Optional specific provider.")
|
||||
(:model :type :string :description "Optional specific model ID."))
|
||||
:body (lambda (args)
|
||||
(execute-llm-request (getf args :prompt)
|
||||
(or (getf args :system-prompt) "You are a helpful assistant.")
|
||||
:provider (getf args :provider)
|
||||
:model (getf args :model))))
|
||||
|
||||
(defskill :skill-llm-gateway
|
||||
:priority 150
|
||||
:trigger (lambda (context) (declare (ignore context)) nil)
|
||||
:probabilistic (lambda (context) (declare (ignore context)) nil)
|
||||
:deterministic (lambda (action context) (declare (ignore context)) action))
|
||||
@@ -1,76 +0,0 @@
|
||||
(defun context-render-to-org (obj &key depth foveal-id semantic-threshold foveal-vector)
|
||||
"Recursively renders an org-object with foveal-peripheral pruning.")
|
||||
|
||||
(defun context-assemble-global-awareness (&optional signal)
|
||||
"Assembles the full context block for a neural request.")
|
||||
|
||||
(defun context-render-to-org (obj &key (depth 1) (foveal-id nil) (semantic-threshold 0.75) (foveal-vector nil))
|
||||
"Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model."
|
||||
(let* ((id (org-object-id obj))
|
||||
(is-foveal (equal id foveal-id))
|
||||
(title (or (getf (org-object-attributes obj) :TITLE) "Untitled"))
|
||||
(content (org-object-content obj))
|
||||
(children (org-object-children obj))
|
||||
(stars (make-string depth :initial-element #\*))
|
||||
(obj-vector (org-object-vector obj))
|
||||
(similarity (if (and foveal-vector obj-vector (not is-foveal))
|
||||
(cosine-similarity foveal-vector obj-vector)
|
||||
0.0))
|
||||
(is-semantically-relevant (>= similarity semantic-threshold))
|
||||
;; We always render depth 1 and 2 (Projects and main tasks).
|
||||
;; We always render the foveal node and its immediate children.
|
||||
;; We render deeper nodes ONLY if they are semantically relevant.
|
||||
(should-render (or (<= depth 2) is-foveal is-semantically-relevant))
|
||||
(output ""))
|
||||
|
||||
(when should-render
|
||||
(setf output (format nil "~a ~a~%:PROPERTIES:~%:ID: ~a~%" stars title id))
|
||||
(when (and is-semantically-relevant (> similarity 0))
|
||||
(setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity))))
|
||||
(setf output (concatenate 'string output (format nil ":END:~%")))
|
||||
|
||||
;; Only include full body content if this is the Foveal focus or highly relevant
|
||||
(when (and content (or is-foveal is-semantically-relevant))
|
||||
(setf output (concatenate 'string output content (string #\Newline))))
|
||||
|
||||
;; Recursively render children
|
||||
(dolist (child-id children)
|
||||
(let ((child-obj (lookup-object child-id)))
|
||||
(when child-obj
|
||||
;; If the current node is Foveal, its children should be rendered (depth effectively resets)
|
||||
(let ((next-foveal (if is-foveal child-id foveal-id)))
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org child-obj
|
||||
:depth (1+ depth)
|
||||
:foveal-id next-foveal
|
||||
:semantic-threshold semantic-threshold
|
||||
:foveal-vector foveal-vector))))))))
|
||||
output))
|
||||
|
||||
(defun context-assemble-global-awareness (&optional signal)
|
||||
"Produces a high-level skeletal outline of the current Memory for the LLM."
|
||||
(let* ((payload (when signal (getf signal :payload)))
|
||||
(foveal-id (when payload (getf payload :target-id)))
|
||||
(foveal-vector (when foveal-id (org-object-vector (lookup-object foveal-id))))
|
||||
(projects (context-get-active-projects))
|
||||
(output "GLOBAL MEMEX AWARENESS (Peripheral Vision):
|
||||
"))
|
||||
(if projects
|
||||
(dolist (project projects)
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org project
|
||||
:foveal-id foveal-id
|
||||
:foveal-vector foveal-vector))))
|
||||
(setf output (concatenate 'string output "No active projects found.~%")))
|
||||
output))
|
||||
|
||||
(defskill :skill-peripheral-vision
|
||||
:priority 90
|
||||
:dependencies ("org-skill-embedding")
|
||||
:trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:perceive :context-refresh)))
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore action ctx))
|
||||
;; This skill primarily provides the context-assemble-global-awareness function
|
||||
;; used by the probabilistic-gate, rather than handling specific actions.
|
||||
nil))
|
||||
@@ -1,225 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *policy-invariant-priorities*
|
||||
'((:transparency . 500)
|
||||
(:autonomy . 400)
|
||||
(:bloat . 300)
|
||||
(:modularity . 250)
|
||||
(:mentorship . 200)
|
||||
(:sustainability . 100))
|
||||
"Priority alist for policy invariant conflict resolution.
|
||||
Higher numbers take precedence.")
|
||||
|
||||
(defun policy-check-transparency (action context)
|
||||
"Ensures the action is inspectable and user-facing actions carry an explanation.
|
||||
Returns the action if clean, or a blocking LOG event if the action is opaque."
|
||||
(declare (ignore context))
|
||||
(unless (listp action)
|
||||
(return-from policy-check-transparency
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Transparency]: Action is not a valid plist. Rejected."))))
|
||||
(let* ((payload (getf action :payload))
|
||||
(target (or (getf action :target) (getf action :TARGET)))
|
||||
(explanation (or (getf payload :explanation) (getf payload :EXPLANATION)
|
||||
(getf payload :rationale) (getf payload :RATIONALE))))
|
||||
;; User-facing actions (CLI, TUI, Emacs) must explain themselves
|
||||
(when (and (member target '(:cli :tui :emacs :EMACS :CLI :TUI))
|
||||
(not explanation)
|
||||
(not (member (getf payload :action)
|
||||
'(:handshake :heartbeat :status-update))))
|
||||
(return-from policy-check-transparency
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Transparency]: User-facing action missing :explanation. Blocked."))))
|
||||
action))
|
||||
|
||||
(defvar *proprietary-domain-watchlist*
|
||||
'("googleapis.com" "api.openai.com" "anthropic.com" "api.groq.com" "openrouter.ai")
|
||||
"Domains that represent centralized, proprietary control.
|
||||
Actions targeting these are logged as autonomy debt, not hard-blocked,
|
||||
because tactical gateway usage is permitted under the strategic mandate.")
|
||||
|
||||
(defun policy-scan-proprietary-references (action)
|
||||
"Scans ACTION text fields for proprietary domain references.
|
||||
Returns the first matched domain, or NIL if clean."
|
||||
(let* ((payload (getf action :payload))
|
||||
(text (or (getf payload :text) (getf payload :TEXT) ""))
|
||||
(cmd (or (getf payload :cmd) (getf payload :CMD)
|
||||
(when (equal (getf payload :tool) "shell")
|
||||
(getf (getf payload :args) :cmd))
|
||||
""))
|
||||
(haystack (concatenate 'string text cmd)))
|
||||
(dolist (domain *proprietary-domain-watchlist* nil)
|
||||
(when (search domain haystack)
|
||||
(return domain)))))
|
||||
|
||||
(defun policy-check-autonomy (action context)
|
||||
"Flags actions that reference proprietary domains. Returns the action
|
||||
with an autonomy debt log appended, or the action itself if clean."
|
||||
(declare (ignore context))
|
||||
(let ((domain (policy-scan-proprietary-references action)))
|
||||
(if domain
|
||||
(progn
|
||||
(harness-log "POLICY [Autonomy]: Detected proprietary reference '~a'. Flagged for replacement." domain)
|
||||
;; Return a side-effect log but DO NOT block the action
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text (format nil "Autonomy Debt: Action references proprietary domain '~a'. Consider a local alternative." domain)
|
||||
:original-action action)))
|
||||
action)))
|
||||
|
||||
(defvar *policy-max-skill-size-chars* 50000
|
||||
"Maximum recommended size for a skill file tangled from an Org note.")
|
||||
|
||||
(defun policy-check-bloat (action context)
|
||||
"Warns if a :create-skill action exceeds the bloat threshold.
|
||||
Does not block, because size alone is not a proof of complexity."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(act (getf payload :action))
|
||||
(content (getf payload :content)))
|
||||
(when (and (eq act :create-skill)
|
||||
(stringp content)
|
||||
(> (length content) *policy-max-skill-size-chars*))
|
||||
(harness-log "POLICY [Bloat]: Proposed skill is ~a chars. Exceeds ~a char threshold."
|
||||
(length content) *policy-max-skill-size-chars*)
|
||||
(return-from policy-check-bloat
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text (format nil "Bloat Warning: Proposed skill (~a chars) exceeds ~a char threshold. Review for earned complexity."
|
||||
(length content) *policy-max-skill-size-chars*)
|
||||
:original-action action))))
|
||||
action))
|
||||
|
||||
(defvar *mentorship-required-actions*
|
||||
'(:create-skill :eval :modify-file :write-file :replace :rename-file :delete-file :shell :create-note)
|
||||
"Actions that trigger the Mentorship invariant.")
|
||||
|
||||
(defun policy-check-mentorship (action context)
|
||||
"Blocks high-impact actions that lack a mentorship note."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(act (or (getf payload :action) (getf action :action)))
|
||||
(note (or (getf payload :mentorship-note) (getf payload :MENTORSHIP-NOTE)))
|
||||
(target (or (getf action :target) (getf action :TARGET)))
|
||||
(tool (when (eq target :tool) (getf payload :tool))))
|
||||
(when (or (member act *mentorship-required-actions*)
|
||||
(member tool '("shell" "eval" "repair-file")))
|
||||
(unless note
|
||||
(return-from policy-check-mentorship
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Mentorship]: High-impact action missing :mentorship-note. Explain what you are doing and why. Blocked.")))))
|
||||
action))
|
||||
|
||||
(defvar *cloud-only-backends* '(:openrouter :openai :anthropic :groq :gemini-api)
|
||||
"Backends that require an internet connection and external infrastructure.")
|
||||
|
||||
(defun policy-check-sustainability (action context)
|
||||
"Logs sustainability debt when the action relies on cloud-only infrastructure.
|
||||
Does not block, because tactical cloud usage is permitted."
|
||||
(let* ((payload (getf context :payload))
|
||||
(backend (getf payload :backend))
|
||||
(provider (getf payload :provider)))
|
||||
(when (or (member backend *cloud-only-backends*)
|
||||
(member provider *cloud-only-backends*))
|
||||
(harness-log "POLICY [Sustainability]: Cloud provider '~a' used. Logged as sustainability debt."
|
||||
(or backend provider))
|
||||
(return-from policy-check-sustainability
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text (format nil "Sustainability Debt: Reliance on cloud provider '~a'. Consider Ollama or local inference."
|
||||
(or backend provider))))))
|
||||
action))
|
||||
|
||||
(defvar *modularity-protected-paths*
|
||||
'("harness/" "opencortex.asd")
|
||||
"Paths that constitute the unbreakable core of the system.
|
||||
Any action targeting these paths must include a :modularity-justification.
|
||||
This list is project-specific and should be configured at boot time.")
|
||||
|
||||
(defun policy-check-modularity (action context)
|
||||
"Blocks modifications to the system's protected core unless justified."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(target-file (or (getf payload :file) (getf payload :filename)))
|
||||
(justification (or (getf payload :modularity-justification)
|
||||
(getf payload :MODULARITY-JUSTIFICATION))))
|
||||
(when (and target-file
|
||||
(some (lambda (path) (search path target-file)) *modularity-protected-paths*)
|
||||
(not justification))
|
||||
(return-from policy-check-modularity
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "POLICY [Modularity]: Modification to protected core path blocked. Provide :modularity-justification explaining why this cannot be a skill."
|
||||
:blocked-path target-file))))
|
||||
action))
|
||||
|
||||
(defun policy-explain (invariant-key message &optional original-action)
|
||||
"Formats a policy decision into an auditable explanation plist.
|
||||
INVARIANT-KEY is one of :transparency, :autonomy, :bloat, :modularity, :mentorship, :sustainability.
|
||||
MESSAGE is a human-readable string.
|
||||
ORIGINAL-ACTION is the action that was blocked or modified."
|
||||
(list :type :REQUEST
|
||||
:target (or (ignore-errors (getf (getf original-action :meta) :source)) :cli)
|
||||
:payload (list :action :message
|
||||
:text (format nil "[POLICY ~a] ~a" invariant-key message)
|
||||
:explanation (format nil "Invariant: ~a | Rationale: ~a" invariant-key message)
|
||||
:original-action original-action)))
|
||||
|
||||
(defun policy-run-invariant-checks (action context)
|
||||
"Runs all invariant checks in priority order. Returns the final action,
|
||||
a blocking LOG event, or a warning wrapper."
|
||||
(let ((checks '(policy-check-transparency
|
||||
policy-check-autonomy
|
||||
policy-check-bloat
|
||||
policy-check-modularity
|
||||
policy-check-mentorship
|
||||
policy-check-sustainability)))
|
||||
(dolist (check-fn checks action)
|
||||
(let ((result (funcall check-fn action context)))
|
||||
;; If the check returned a LOG event, treat it as a block/warning
|
||||
(when (and (listp result)
|
||||
(member (getf result :type) '(:LOG :EVENT)))
|
||||
(let ((level (getf (getf result :payload) :level)))
|
||||
(cond ((eq level :error)
|
||||
;; Hard block: return the log event directly
|
||||
(return-from policy-run-invariant-checks result))
|
||||
(t
|
||||
;; Warning: log it, but continue with the original action
|
||||
(harness-log "~a" (getf (getf result :payload) :text))))))))))
|
||||
|
||||
(defun policy-find-engineering-standards-gate ()
|
||||
"Searches for the Engineering Standards gate across known jailed package names.
|
||||
Returns the function symbol, or NIL if unavailable."
|
||||
(dolist (pkg-name '(:opencortex.skills.org-skill-engineering-standards
|
||||
:opencortex.skills.org-skill-engineering
|
||||
:opencortex.skills.engineering-standards)
|
||||
nil)
|
||||
(let ((pkg (find-package pkg-name)))
|
||||
(when pkg
|
||||
(let ((sym (find-symbol "ENGINEERING-STANDARDS-GATE" pkg)))
|
||||
(when (and sym (fboundp sym))
|
||||
(return (symbol-function sym))))))))
|
||||
|
||||
(defun policy-deterministic-gate (action context)
|
||||
"The main policy gate. Runs invariant checks, then delegates to engineering standards if available.
|
||||
Never returns NIL silently; always returns an action or an auditable log event."
|
||||
(let ((current-action (policy-run-invariant-checks action context)))
|
||||
;; If an invariant returned a blocking log, do not proceed further
|
||||
(when (and (listp current-action)
|
||||
(member (getf current-action :type) '(:LOG :EVENT))
|
||||
(eq (getf (getf current-action :payload) :level) :error))
|
||||
(return-from policy-deterministic-gate current-action))
|
||||
;; Delegate to Engineering Standards if loaded
|
||||
(let ((eng-gate (policy-find-engineering-standards-gate)))
|
||||
(when eng-gate
|
||||
(setf current-action (funcall eng-gate current-action context))))
|
||||
current-action))
|
||||
|
||||
(defskill :skill-policy
|
||||
:priority 500
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:probabilistic nil
|
||||
:deterministic #'policy-deterministic-gate)
|
||||
@@ -1,44 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Strict structural validation for incoming communication protocol messages."
|
||||
(unless (listp msg)
|
||||
(error "Communication Protocol Schema Error: Message must be a property list (got ~s)" (type-of msg)))
|
||||
|
||||
(let ((type (let ((raw (proto-get msg :type))) (if (keywordp raw) (intern (string-upcase (string raw)) :keyword) raw))))
|
||||
(unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS :CHAT))
|
||||
(progn (harness-log "REJECTED MSG: ~s" msg) (error "Communication Protocol Schema Error: Invalid message type '~a'" type)))
|
||||
|
||||
(case type
|
||||
(:REQUEST
|
||||
;; Allow missing :target if :source is present in :meta, since reason-gate
|
||||
;; will infer :target from :source downstream. This preserves "equality of
|
||||
;; clients" — gateways need not duplicate routing logic.
|
||||
(let ((target (proto-get msg :target))
|
||||
(source (proto-get (proto-get msg :meta) :source)))
|
||||
(unless (or target source)
|
||||
(error "Communication Protocol Schema Error: REQUEST missing mandatory :target and no :source in :meta to infer it"))
|
||||
(unless (proto-get msg :payload)
|
||||
(error "Communication Protocol Schema Error: REQUEST missing mandatory :payload"))))
|
||||
|
||||
(:EVENT
|
||||
(let ((payload (proto-get msg :payload)))
|
||||
(unless (and payload (listp payload))
|
||||
(error "Communication Protocol Schema Error: EVENT missing or invalid :payload"))
|
||||
(unless (or (proto-get payload :action) (proto-get payload :sensor))
|
||||
(error "Communication Protocol Schema Error: EVENT payload must contain :action or :sensor"))))
|
||||
|
||||
(:RESPONSE
|
||||
(unless (proto-get msg :payload)
|
||||
(error "Communication Protocol Schema Error: RESPONSE missing mandatory :payload"))))
|
||||
|
||||
t))
|
||||
|
||||
(defskill :skill-communication-protocol-validator
|
||||
:priority 95
|
||||
:trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:protocol-received)))
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(validate-communication-protocol-schema action)
|
||||
action))
|
||||
@@ -1,108 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *scribe-last-checkpoint* 0
|
||||
"The universal-time of the last successful distillation run.")
|
||||
|
||||
(defun scribe-load-state ()
|
||||
"Loads the scribe checkpoint from the state directory."
|
||||
(let ((state-file (uiop:merge-pathnames* "state/scribe-checkpoint.lisp" (asdf:system-source-directory :opencortex))))
|
||||
(if (uiop:file-exists-p state-file)
|
||||
(setf *scribe-last-checkpoint* (read-from-string (uiop:read-file-string state-file)))
|
||||
(setf *scribe-last-checkpoint* 0))))
|
||||
|
||||
(defun scribe-save-state ()
|
||||
"Saves the current universal-time as the new checkpoint."
|
||||
(let ((state-file (uiop:merge-pathnames* "state/scribe-checkpoint.lisp" (asdf:system-source-directory :opencortex))))
|
||||
(ensure-directories-exist state-file)
|
||||
(with-open-file (out state-file :direction :output :if-exists :supersede)
|
||||
(format out "~a" (get-universal-time)))))
|
||||
|
||||
(defun scribe-get-distillable-nodes ()
|
||||
"Returns a list of org-objects from the daily/ folder that require distillation."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let* ((attrs (org-object-attributes obj))
|
||||
(tags (getf attrs :TAGS))
|
||||
(type (org-object-type obj))
|
||||
(version (org-object-version obj)))
|
||||
(when (and (eq type :HEADLINE)
|
||||
(> version *scribe-last-checkpoint*)
|
||||
(not (member "@personal" tags :test #'string-equal)))
|
||||
(push obj results))))
|
||||
*memory*)
|
||||
results))
|
||||
|
||||
(defun probabilistic-skill-scribe (context)
|
||||
"Generates the extraction prompt for the Scribe."
|
||||
(let* ((payload (getf context :payload))
|
||||
(nodes (scribe-get-distillable-nodes)))
|
||||
(if nodes
|
||||
(let ((text-to-process ""))
|
||||
(dolist (node nodes)
|
||||
(setf text-to-process (concatenate 'string text-to-process
|
||||
(format nil "ID: ~a~%TITLE: ~a~%CONTENT: ~a~%---~%"
|
||||
(org-object-id node)
|
||||
(getf (org-object-attributes node) :TITLE)
|
||||
(org-object-content node)))))
|
||||
(format nil "DISTILLATION TASK:
|
||||
Below are raw chronological logs from my daily journal.
|
||||
Extract ATOMIC EVERGREEN NOTES from this text.
|
||||
|
||||
RULES:
|
||||
1. One note per distinct concept.
|
||||
2. Output a list of Lisp plists: ((:title \"...\" :content \"...\" :source-id \"...\") ...)
|
||||
3. The content should be in Org-mode format.
|
||||
4. Keep titles descriptive and snake_case.
|
||||
|
||||
TEXT:
|
||||
~a" text-to-process))
|
||||
nil)))
|
||||
|
||||
(defun scribe-commit-notes (proposals)
|
||||
"Writes proposed atomic notes to the notes/ directory. Appends if the note exists."
|
||||
(let ((notes-dir (uiop:merge-pathnames* "notes/" (asdf:system-source-directory :opencortex))))
|
||||
(ensure-directories-exist notes-dir)
|
||||
(dolist (note proposals)
|
||||
(let* ((title (getf note :title))
|
||||
(content (getf note :content))
|
||||
(source-id (getf note :source-id))
|
||||
(filename (format nil "~a.org" (string-downcase (cl-ppcre:regex-replace-all " " title "_"))))
|
||||
(path (merge-pathnames filename notes-dir)))
|
||||
(if (uiop:file-exists-p path)
|
||||
(with-open-file (out path :direction :output :if-exists :append)
|
||||
(format out "~%~%* Appended insight from ~a~%~a" source-id content))
|
||||
(with-open-file (out path :direction :output :if-exists :supersede)
|
||||
(format out ":PROPERTIES:~%:ID: ~a~%:SOURCE_ID: ~a~%:END:~%#+TITLE: ~a~%~%~a"
|
||||
(org-id-new) source-id title content)))
|
||||
(harness-log "SCRIBE: Processed evergreen note ~a" filename)))))
|
||||
|
||||
(defun verify-skill-scribe (action context)
|
||||
"Executes the note creation and marks source nodes as distilled."
|
||||
(declare (ignore context))
|
||||
(let ((data (cond ((and (listp action) (eq (getf action :type) :REQUEST))
|
||||
(getf (getf action :payload) :payload))
|
||||
((and (listp action) (not (member (getf action :type) '(:LOG :EVENT))))
|
||||
action)
|
||||
(t nil))))
|
||||
(when data
|
||||
(harness-log "SCRIBE: Committing ~a atomic notes..." (length data))
|
||||
(scribe-commit-notes data)
|
||||
(scribe-save-state)
|
||||
(harness-log "SCRIBE: Distillation complete.")
|
||||
;; Return a log event to stop the loop
|
||||
(list :type :LOG :payload (list :text "Distillation successful.")))))
|
||||
|
||||
(defskill :skill-scribe
|
||||
:priority 50
|
||||
:trigger (lambda (ctx)
|
||||
(let* ((payload (getf ctx :payload))
|
||||
(sensor (getf payload :sensor)))
|
||||
(and (eq sensor :heartbeat)
|
||||
;; Only run once per hour to check if we need to distill
|
||||
(> (- (get-universal-time) *scribe-last-checkpoint*) 3600)
|
||||
(scribe-get-distillable-nodes))))
|
||||
:probabilistic #'probabilistic-skill-scribe
|
||||
:deterministic #'verify-skill-scribe)
|
||||
|
||||
(scribe-load-state)
|
||||
@@ -1,56 +0,0 @@
|
||||
(defparameter *allowed-commands* '("ls" "git" "rg" "grep" "date" "echo" "cat" "node" "python3" "sbcl"))
|
||||
|
||||
(defparameter *shell-metacharacters* '(#\; #\& #\| #\> #\< #\$ #\` #\\ #\!))
|
||||
|
||||
(defun shell-command-safe-p (cmd-string)
|
||||
"Returns T if the command string contains no dangerous metacharacters."
|
||||
(not (some (lambda (char) (find char cmd-string)) *shell-metacharacters*)))
|
||||
|
||||
(defun execute-shell-safely (action context)
|
||||
(let* ((payload (getf action :PAYLOAD))
|
||||
(cmd-string (getf payload :cmd))
|
||||
(executable (car (uiop:split-string (string-trim " " cmd-string) :separator '(#\Space)))))
|
||||
|
||||
(cond
|
||||
((not (shell-command-safe-p cmd-string))
|
||||
(opencortex:inject-stimulus
|
||||
`(:TYPE :EVENT :PAYLOAD (:SENSOR :shell-response :cmd ,cmd-string :stdout "" :stderr "ERROR - Security Violation: Dangerous metacharacters detected." :exit-code 1))
|
||||
:stream (getf context :reply-stream)))
|
||||
|
||||
((not (member executable *allowed-commands* :test #'string=))
|
||||
(opencortex:inject-stimulus
|
||||
`(:TYPE :EVENT :PAYLOAD (:SENSOR :shell-response :cmd ,cmd-string :stdout "" :stderr "ERROR - Command not in security whitelist." :exit-code 1))
|
||||
:stream (getf context :reply-stream)))
|
||||
|
||||
(t
|
||||
(multiple-value-bind (stdout stderr exit-code)
|
||||
(uiop:run-program cmd-string :output :string :error-output :string :ignore-error-status t)
|
||||
(opencortex:inject-stimulus
|
||||
`(:TYPE :EVENT :PAYLOAD (:SENSOR :shell-response :cmd ,cmd-string :stdout ,(or stdout "") :stderr ,(or stderr "") :exit-code ,exit-code))
|
||||
:stream (getf context :reply-stream)))))))
|
||||
|
||||
(defun trigger-skill-shell-actuator (context)
|
||||
(let ((type (getf context :TYPE))
|
||||
(payload (getf context :PAYLOAD)))
|
||||
(and (eq type :EVENT)
|
||||
(eq (getf payload :SENSOR) :shell-response))))
|
||||
|
||||
(defun probabilistic-skill-shell-actuator (context)
|
||||
(let* ((p (getf context :PAYLOAD))
|
||||
(cmd (getf p :cmd))
|
||||
(stdout (getf p :stdout))
|
||||
(stderr (getf p :stderr))
|
||||
(exit-code (getf p :exit-code)))
|
||||
(format nil "SHELL COMMAND RESULT:
|
||||
Command: ~a
|
||||
Exit Code: ~a
|
||||
STDOUT: ~a
|
||||
STDERR: ~a" cmd exit-code stdout stderr)))
|
||||
|
||||
(opencortex:register-actuator :shell #'execute-shell-safely)
|
||||
|
||||
(defskill :skill-shell-actuator
|
||||
:priority 80
|
||||
:trigger #'trigger-skill-shell-actuator
|
||||
:probabilistic #'probabilistic-skill-shell-actuator
|
||||
:deterministic (lambda (action context) (declare (ignore context)) action))
|
||||
@@ -1,99 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *interrupt-flag* nil)
|
||||
(defvar *interrupt-lock* (bt:make-lock "harness-interrupt-lock"))
|
||||
(defvar *heartbeat-thread* nil)
|
||||
|
||||
(defun process-signal (signal)
|
||||
"The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act."
|
||||
(let ((current-signal signal))
|
||||
(loop while current-signal do
|
||||
(let ((depth (getf current-signal :depth 0))
|
||||
(meta (getf current-signal :meta)))
|
||||
(when (> depth 10) (harness-log "METABOLISM ERROR: Max depth reached.") (return nil))
|
||||
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
|
||||
(harness-log "METABOLISM: Interrupted.")
|
||||
(bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* nil))
|
||||
(return nil))
|
||||
(handler-case
|
||||
(progn
|
||||
(setf current-signal (perceive-gate current-signal))
|
||||
(setf current-signal (reason-gate current-signal))
|
||||
(let ((feedback (act-gate current-signal)))
|
||||
;; feedback generation
|
||||
(if feedback
|
||||
(progn
|
||||
;; Inherit meta from trigger signal
|
||||
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
|
||||
(setf current-signal feedback))
|
||||
(setf current-signal nil))))
|
||||
(error (c)
|
||||
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
|
||||
(harness-log "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
|
||||
;; Only rollback on critical errors, not standard tool or loop errors
|
||||
(unless (member sensor '(:loop-error :tool-error :syntax-error))
|
||||
(harness-log "CRITICAL ERROR: Initiating Micro-Rollback.")
|
||||
(rollback-memory 0))
|
||||
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
|
||||
(setf current-signal nil)
|
||||
(setf current-signal (list :type :EVENT :depth (1+ depth) :meta meta
|
||||
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))))))
|
||||
|
||||
(defvar *auto-save-interval* 300
|
||||
"Save memory to disk every N seconds. Set from MEMORY_AUTO_SAVE_INTERVAL env.")
|
||||
|
||||
(defvar *heartbeat-save-counter* 0
|
||||
"Counter for auto-save triggers.")
|
||||
|
||||
(defun start-heartbeat ()
|
||||
"Starts the background heartbeat thread. Interval is loaded from HEARTBEAT_INTERVAL."
|
||||
(let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60))
|
||||
(auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) *auto-save-interval*)))
|
||||
(setf *auto-save-interval* auto-save)
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
(setf *heartbeat-thread*
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(sleep interval)
|
||||
(incf *heartbeat-save-counter*)
|
||||
(when (>= *heartbeat-save-counter* (/ *auto-save-interval* interval))
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
(save-memory-to-disk))
|
||||
;; inject-stimulus is synchronous for heartbeats, preventing accumulation.
|
||||
(inject-stimulus (list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
|
||||
:name "opencortex-heartbeat"))))
|
||||
|
||||
(defvar *shutdown-save-enabled* t
|
||||
"If non-nil, save memory to disk on graceful shutdown.")
|
||||
|
||||
(defun main ()
|
||||
"Entry point for the Skeleton MVP. Handles initialization and graceful shutdown."
|
||||
(let* ((home (uiop:getenv "HOME"))
|
||||
(env-file (uiop:merge-pathnames* ".local/share/opencortex/.env" (uiop:ensure-directory-pathname home))))
|
||||
(when (uiop:file-exists-p env-file) (cl-dotenv:load-env env-file)))
|
||||
|
||||
;; Load memory from disk if a snapshot exists
|
||||
(load-memory-from-disk)
|
||||
|
||||
(initialize-actuators)
|
||||
(initialize-all-skills)
|
||||
|
||||
(start-heartbeat)
|
||||
|
||||
;; Graceful shutdown handler for SBCL
|
||||
#+sbcl
|
||||
(sb-sys:enable-interrupt sb-unix:sigint
|
||||
(lambda (sig code scp)
|
||||
(declare (ignore sig code scp))
|
||||
(harness-log "SHUTDOWN: SIGINT received. Saving memory...")
|
||||
(when *shutdown-save-enabled* (save-memory-to-disk))
|
||||
(uiop:quit 0)))
|
||||
|
||||
(let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600)))
|
||||
(loop
|
||||
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
|
||||
(harness-log "SHUTDOWN: Interrupt flag set. Saving memory...")
|
||||
(when *shutdown-save-enabled* (save-memory-to-disk))
|
||||
(return))
|
||||
(sleep sleep-interval))))
|
||||
@@ -1,163 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *memory* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *history-store* (make-hash-table :test 'equal)
|
||||
"Immutable Merkle-Tree versioning store mapping hashes to objects.")
|
||||
|
||||
(defstruct org-object
|
||||
id type attributes content vector parent-id children version last-sync hash)
|
||||
|
||||
(defun compute-merkle-hash (id type attributes content child-hashes)
|
||||
"Computes a SHA-256 Merkle hash for a node based on its core properties and children's hashes."
|
||||
(let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v)))
|
||||
(sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x)))))
|
||||
(attr-string (format nil "~s" sorted-alist))
|
||||
(children-string (format nil "~{~a~}" child-hashes))
|
||||
(data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a"
|
||||
id type attr-string (or content "") children-string))
|
||||
(digester (ironclad:make-digest :sha256)))
|
||||
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string))
|
||||
(ironclad:byte-array-to-hex-string (ironclad:produce-digest digester))))
|
||||
|
||||
(defun ingest-ast (ast &optional parent-id)
|
||||
"Parses an Org AST into the recursive Lisp Memory with Merkle hashing."
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (or (getf props :ID) (format nil "temp-~a" (get-universal-time))))
|
||||
(contents (getf ast :contents))
|
||||
(raw-content (when (eq type :HEADLINE)
|
||||
(format nil "~a~%~a" (getf props :TITLE) (or (cl:getf ast :raw-content) ""))))
|
||||
(should-embed (and raw-content (equal (getf props :EMBED) "t")))
|
||||
(child-ids nil)
|
||||
(child-hashes nil))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(let ((child-id (ingest-ast child id)))
|
||||
(push child-id child-ids)
|
||||
(let ((child-id-val child-id))
|
||||
(let ((child-obj (lookup-object child-id-val)))
|
||||
(when child-obj (push (org-object-hash child-obj) child-hashes)))))))
|
||||
(setf child-ids (nreverse child-ids))
|
||||
(setf child-hashes (nreverse child-hashes))
|
||||
(let* ((hash (compute-merkle-hash id type props raw-content child-hashes))
|
||||
(existing-obj (gethash hash *history-store*))
|
||||
(obj (or existing-obj
|
||||
(make-org-object
|
||||
:id id :type type :attributes props :content raw-content
|
||||
:vector (when should-embed (get-embedding raw-content))
|
||||
:parent-id parent-id :children child-ids
|
||||
:version (get-universal-time) :last-sync (get-universal-time)
|
||||
:hash hash))))
|
||||
(unless existing-obj
|
||||
(setf (gethash hash *history-store*) obj))
|
||||
(setf (gethash id *memory*) obj)
|
||||
id)))
|
||||
|
||||
(defvar *object-store-snapshots* nil)
|
||||
|
||||
(defun copy-hash-table (hash-table)
|
||||
"Creates a shallow copy of a hash table."
|
||||
(let ((new-table (make-hash-table :test (hash-table-test hash-table)
|
||||
:size (hash-table-size hash-table))))
|
||||
(maphash (lambda (k v) (setf (gethash k new-table) v)) hash-table)
|
||||
new-table))
|
||||
|
||||
(defun snapshot-memory ()
|
||||
"Creates a lightweight, Copy-on-Write snapshot using Merkle-Tree pointers."
|
||||
(let ((snapshot (copy-hash-table *memory*)))
|
||||
(push (list :timestamp (get-universal-time) :data snapshot) *object-store-snapshots*)
|
||||
(when (> (length *object-store-snapshots*) 20)
|
||||
(setf *object-store-snapshots* (subseq *object-store-snapshots* 0 20)))
|
||||
(harness-log "MEMORY - CoW Memory snapshot created.")))
|
||||
|
||||
(defun rollback-memory (&optional (index 0))
|
||||
"Restores the Memory to a previously captured snapshot using immutable history pointers."
|
||||
(let ((snapshot (nth index *object-store-snapshots*)))
|
||||
(if snapshot
|
||||
(progn (setf *memory* (copy-hash-table (getf snapshot :data)))
|
||||
(harness-log "MEMORY - Memory rolled back to snapshot ~a" index))
|
||||
(harness-log "MEMORY ERROR - Snapshot ~a not found." index))))
|
||||
|
||||
(defvar *memory-snapshot-path* nil
|
||||
"Path to the memory snapshot file. Set from MEMORY_SNAPSHOT_PATH env or default.")
|
||||
|
||||
(defun ensure-memory-snapshot-path ()
|
||||
"Initializes the snapshot path from environment or default location."
|
||||
(or *memory-snapshot-path*
|
||||
(let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH")))
|
||||
(setf *memory-snapshot-path*
|
||||
(or env-path
|
||||
(uiop:merge-pathnames* "memory.snap" (user-homedir-pathname)))))))
|
||||
|
||||
(defun save-memory-to-disk ()
|
||||
"Serializes *memory* and *history-store* to disk for crash recovery.
|
||||
Converts hash tables to alists for proper serialization."
|
||||
(let ((path (ensure-memory-snapshot-path)))
|
||||
(with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(format stream ";; OpenCortex Memory Snapshot~%")
|
||||
(format stream ";; Created: ~a~%~%" (format nil "~a" (get-universal-time)))
|
||||
(let ((memory-alist nil)
|
||||
(history-alist nil))
|
||||
(maphash (lambda (k v) (push (cons k v) memory-alist)) *memory*)
|
||||
(maphash (lambda (k v) (push (cons k v) history-alist)) *history-store*)
|
||||
(prin1 (list :memory memory-alist :history-store history-alist) stream)))
|
||||
(harness-log "MEMORY - Saved to ~a" path)
|
||||
path))
|
||||
|
||||
(defun load-memory-from-disk ()
|
||||
"Loads *memory* and *history-store* from disk if the snapshot exists.
|
||||
Reconstitutes alists into hash tables."
|
||||
(let ((path (ensure-memory-snapshot-path)))
|
||||
(when (uiop:file-exists-p path)
|
||||
(handler-case
|
||||
(with-open-file (stream path :direction :input)
|
||||
(let ((data (read stream nil)))
|
||||
(when data
|
||||
(let ((memory-alist (getf data :memory))
|
||||
(history-alist (getf data :history-store)))
|
||||
(setf *memory* (make-hash-table :test 'equal :size (length memory-alist)))
|
||||
(dolist (kv memory-alist)
|
||||
(setf (gethash (car kv) *memory*) (cdr kv)))
|
||||
(setf *history-store* (make-hash-table :test 'equal :size (length history-alist)))
|
||||
(dolist (kv history-alist)
|
||||
(setf (gethash (car kv) *history-store*) (cdr kv)))
|
||||
(harness-log "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory*))))))
|
||||
(error (c)
|
||||
(harness-log "MEMORY WARNING - Failed to load snapshot: ~a" c))))
|
||||
t))
|
||||
|
||||
(defun org-id-new ()
|
||||
"Generates a new UUID string for Org-mode identification."
|
||||
(string-downcase (format nil "~a" (uuid:make-v4-uuid))))
|
||||
|
||||
(defun lookup-object (id)
|
||||
"Retrieves an object from the store by its unique ID."
|
||||
(gethash id *memory*))
|
||||
|
||||
(defun list-objects-by-type (type)
|
||||
"Returns a list of all objects matching a specific Org element type."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj) (declare (ignore id)) (when (eq (org-object-type obj) type) (push obj results))) *memory*)
|
||||
results))
|
||||
(defun list-objects-with-attribute (attr-name value)
|
||||
"Returns a list of all objects where ATTR-NAME matches VALUE."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(let ((attrs (org-object-attributes obj)))
|
||||
(when (equal (getf attrs attr-name) value)
|
||||
(push obj results))))
|
||||
*memory*)
|
||||
results))
|
||||
|
||||
(defun find-headline-missing-id (ast)
|
||||
"Traverses an AST to find headlines that lack an :ID: property."
|
||||
(when (listp ast)
|
||||
(if (and (eq (getf ast :type) :HEADLINE) (not (getf (getf ast :properties) :ID)))
|
||||
ast
|
||||
(cl:some #'find-headline-missing-id (getf ast :contents)))))
|
||||
|
||||
(defun file-name-nondirectory (path)
|
||||
"Extracts the filename from a full path string."
|
||||
(let ((pos (position #\/ path :from-end t))) (if pos (subseq path (1+ pos)) path)))
|
||||
@@ -1,187 +0,0 @@
|
||||
(defpackage :opencortex
|
||||
(:use :cl)
|
||||
(:export
|
||||
;; --- communication protocol ---
|
||||
#:frame-message
|
||||
#:read-framed-message
|
||||
#:PROTO-GET
|
||||
#:LIST-OBJECTS-WITH-ATTRIBUTE
|
||||
#:COSINE-SIMILARITY
|
||||
#:VAULT-MASK-STRING
|
||||
#:*VAULT-MEMORY*
|
||||
#:parse-message
|
||||
#:make-hello-message
|
||||
#:validate-communication-protocol-schema
|
||||
|
||||
;; --- Daemon Lifecycle ---
|
||||
#:start-daemon
|
||||
#:stop-daemon
|
||||
#:harness-log
|
||||
#:main
|
||||
|
||||
;; --- Memory (CLOSOS) ---
|
||||
#:ingest-ast
|
||||
#:lookup-object
|
||||
#:list-objects-by-type
|
||||
#:org-id-new
|
||||
#:*memory*
|
||||
#:*history-store*
|
||||
#:org-object
|
||||
#:make-org-object
|
||||
#:org-object-id
|
||||
#:org-object-type
|
||||
#:org-object-attributes
|
||||
#:org-object-parent-id
|
||||
#:org-object-children
|
||||
#:org-object-version
|
||||
#:org-object-last-sync
|
||||
#:org-object-vector
|
||||
#:org-object-content
|
||||
#:org-object-hash
|
||||
#:snapshot-memory
|
||||
#:rollback-memory
|
||||
#:save-memory-to-disk
|
||||
#:load-memory-from-disk
|
||||
|
||||
;; --- Context API (Peripheral Vision) ---
|
||||
#:context-query-store
|
||||
#:context-get-active-projects
|
||||
#:context-get-recent-completed-tasks
|
||||
#:context-list-all-skills
|
||||
#:context-get-skill-source
|
||||
#:context-get-system-logs
|
||||
#:context-resolve-path
|
||||
#:context-get-skill-telemetry
|
||||
#:harness-track-telemetry
|
||||
#:context-assemble-global-awareness
|
||||
|
||||
;; --- Reactive Signal Pipeline ---
|
||||
#:process-signal
|
||||
#:perceive-gate
|
||||
#:probabilistic-gate
|
||||
#:consensus-gate
|
||||
#:act-gate
|
||||
#:reason-gate
|
||||
#:perceive-gate
|
||||
#:dispatch-gate
|
||||
#:inject-stimulus
|
||||
#:initialize-actuators
|
||||
#:dispatch-action
|
||||
#:register-actuator
|
||||
|
||||
;; --- Skill Engine ---
|
||||
#:load-skill-from-org
|
||||
#:initialize-all-skills
|
||||
#:load-skill-with-timeout
|
||||
#:topological-sort-skills
|
||||
#:validate-lisp-syntax
|
||||
#:defskill
|
||||
#:*skills-registry*
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-dependencies
|
||||
#:skill-trigger-fn
|
||||
#:skill-probabilistic-prompt
|
||||
#:skill-deterministic-fn
|
||||
|
||||
;; --- Tool Registry ---
|
||||
#:def-cognitive-tool
|
||||
#:*cognitive-tools*
|
||||
#:cognitive-tool
|
||||
#:cognitive-tool-name
|
||||
#:cognitive-tool-description
|
||||
#:cognitive-tool-parameters
|
||||
#:cognitive-tool-guard
|
||||
#:cognitive-tool-body
|
||||
|
||||
;; --- Emacs Client Registry ---
|
||||
#:*emacs-clients*
|
||||
#:*clients-lock*
|
||||
#:register-emacs-client
|
||||
#:unregister-emacs-client
|
||||
|
||||
;; --- Probabilistic Engine ---
|
||||
#:ask-probabilistic
|
||||
#:register-probabilistic-backend
|
||||
#:distill-prompt
|
||||
#:*provider-cascade*
|
||||
|
||||
;; --- Security Vault ---
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
|
||||
;; --- Deterministic Logic ---
|
||||
#:list-objects-with-attribute
|
||||
#:deterministic-verify
|
||||
|
||||
;; --- AST Helpers ---
|
||||
#:find-headline-missing-id))
|
||||
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
"Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
"Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *system-logs* nil)
|
||||
(defvar *logs-lock* (bt:make-lock "harness-logs-lock"))
|
||||
(defvar *max-log-history* 100)
|
||||
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded skills.")
|
||||
|
||||
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bt:make-lock "harness-telemetry-lock"))
|
||||
|
||||
(defun harness-track-telemetry (skill-name duration status)
|
||||
"Updates performance metrics for a specific skill. Status should be :success or :rejected."
|
||||
(when skill-name
|
||||
(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)))))
|
||||
|
||||
(defvar *cognitive-tools* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct cognitive-tool
|
||||
name
|
||||
description
|
||||
parameters
|
||||
guard
|
||||
body)
|
||||
|
||||
(defmacro def-cognitive-tool (name description parameters &key guard body)
|
||||
"Registers a new cognitive tool into the global registry. Parameters must be a list of property lists."
|
||||
`(setf (gethash (string-downcase (string ',name)) *cognitive-tools*)
|
||||
(make-cognitive-tool :name (string-downcase (string ',name))
|
||||
:description ,description
|
||||
:parameters ',parameters
|
||||
:guard ,guard
|
||||
:body ,body)))
|
||||
|
||||
(defun harness-log (msg &rest args)
|
||||
"Centralized logging for the harness."
|
||||
(let ((formatted-msg (apply #'format nil msg args)))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(push formatted-msg *system-logs*)
|
||||
(when (> (length *system-logs*) *max-log-history*)
|
||||
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||
(format t "~a~%" formatted-msg)
|
||||
(finish-output)))
|
||||
@@ -1,60 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *async-sensors* '(:chat-message :delegation :user-command)
|
||||
"List of sensors that should be processed asynchronously to avoid blocking gateways.")
|
||||
|
||||
(defvar *foveal-focus-id* nil
|
||||
"The Org ID of the node the user is currently interacting with.")
|
||||
|
||||
(defun inject-stimulus (raw-message &key stream (depth 0))
|
||||
"Enqueues a raw message into the reactive signal pipeline."
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
(sensor (getf payload :sensor))
|
||||
(meta (getf raw-message :meta))
|
||||
(async-p (or (getf payload :async-p) (member sensor *async-sensors*))))
|
||||
|
||||
;; Ensure META exists and contains the stream if provided
|
||||
(unless meta (setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal")))
|
||||
(when stream (setf (getf meta :reply-stream) stream))
|
||||
(setf (getf raw-message :meta) meta)
|
||||
|
||||
(if async-p
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(restart-case (handler-bind ((error (lambda (c) (harness-log "ASYNC ERROR: ~a" c) (invoke-restart 'skip-event))))
|
||||
(process-signal raw-message))
|
||||
(skip-event () nil)))
|
||||
:name "opencortex-async-task")
|
||||
(restart-case (handler-bind ((error (lambda (c) (harness-log "SYSTEM ERROR: ~a" c) (invoke-restart 'skip-event))))
|
||||
(process-signal raw-message))
|
||||
(skip-event () (harness-log "SYSTEM RECOVERY: Stimulus dropped.~%"))))))
|
||||
|
||||
(defun perceive-gate (signal)
|
||||
"Initial processing: Normalizes raw stimuli and updates memory."
|
||||
(let* ((payload (getf signal :payload))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(sensor (getf payload :sensor)))
|
||||
(harness-log "GATE [Perceive]: ~a (~a) [Source: ~s]" type (or sensor "no-sensor") (getf meta :source))
|
||||
|
||||
(cond ((eq type :EVENT)
|
||||
(case sensor
|
||||
(:buffer-update
|
||||
(let ((ast (getf payload :ast)))
|
||||
(when ast
|
||||
(snapshot-memory)
|
||||
(ingest-ast ast))))
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element
|
||||
(snapshot-memory)
|
||||
(setf *foveal-focus-id* (ignore-errors (getf element :id)))
|
||||
(ingest-ast element))))
|
||||
(:interrupt
|
||||
(bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* t)))))
|
||||
((eq type :RESPONSE)
|
||||
(harness-log "GATE [Perceive]: Act Result -> ~a" (getf payload :status))))
|
||||
|
||||
(setf (getf signal :status) :perceived)
|
||||
(setf (getf signal :foveal-focus) *foveal-focus-id*)
|
||||
signal))
|
||||
Binary file not shown.
@@ -1,133 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(defvar *provider-cascade* nil)
|
||||
(defvar *model-selector-fn* nil)
|
||||
(defvar *consensus-enabled-p* nil)
|
||||
|
||||
(defun register-probabilistic-backend (name fn)
|
||||
"Registers a neural provider (e.g., :gemini, :anthropic) with its calling function."
|
||||
(setf (gethash name *probabilistic-backends*) fn))
|
||||
|
||||
(defun probabilistic-call (prompt &key (system-prompt "You are the Probabilistic engine.") (cascade nil) (context nil))
|
||||
"Dispatches a neural request through the provider cascade. Returns a Lisp plist or a failure log."
|
||||
(let ((backends (or cascade *provider-cascade*)))
|
||||
(or (dolist (backend backends)
|
||||
(let ((backend-fn (gethash backend *probabilistic-backends*)))
|
||||
(when backend-fn
|
||||
(harness-log "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model (when *model-selector-fn* (funcall *model-selector-fn* backend context)))
|
||||
(result (if model
|
||||
(funcall backend-fn prompt system-prompt :model model)
|
||||
(funcall backend-fn prompt system-prompt))))
|
||||
(cond ((and (listp result) (eq (getf result :status) :success))
|
||||
(return (getf result :content)))
|
||||
((stringp result) (return result))
|
||||
(t (harness-log "PROBABILISTIC: Backend ~a failed: ~a" backend (getf result :message))))))))
|
||||
(list :type :LOG :payload (list :text "Neural Cascade Failure: All providers exhausted.")))))
|
||||
|
||||
(defun strip-markdown (text)
|
||||
"Strips common markdown code block markers from text."
|
||||
(if (and text (stringp text))
|
||||
(let ((cleaned text))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
|
||||
(string-trim '(#\Space #\Newline #\Tab) cleaned))
|
||||
text))
|
||||
|
||||
(defun normalize-plist-keywords (plist)
|
||||
"Normalize all keys in a plist to keywords (e.g., TYPE -> :TYPE)."
|
||||
(when (listp plist)
|
||||
(loop for (k . rest) on plist by #'cddr
|
||||
collect (if (and (symbolp k) (not (keywordp k)))
|
||||
(intern (string k) :keyword)
|
||||
k)
|
||||
collect (car rest))))
|
||||
|
||||
(defun think (context)
|
||||
"Generates a Lisp action proposal based on current context."
|
||||
(let* ((active-skill (find-triggered-skill context))
|
||||
(tool-belt (generate-tool-belt-prompt))
|
||||
(global-context (context-assemble-global-awareness))
|
||||
(system-logs (context-get-system-logs))
|
||||
(assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent")))
|
||||
(let* ((prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
|
||||
(raw-prompt (if prompt-generator
|
||||
(funcall prompt-generator context)
|
||||
(let ((p (proto-get (proto-get context :payload) :text)))
|
||||
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
|
||||
(system-prompt (format nil "IDENTITY: ~a. MANDATE: Respond with ONE Lisp plist. ~a ~a RECENT_LOGS: ~a
|
||||
IMPORTANT: To reply to the user, you MUST use:
|
||||
(:TYPE :REQUEST :PAYLOAD (:ACTION :MESSAGE :TEXT \"<Response Text>\"))
|
||||
|
||||
To call a tool, you MUST use:
|
||||
(:TYPE :REQUEST :TARGET :TOOL :ACTION :CALL :TOOL \"<name>\" :ARGS (:arg1 \"val\"))
|
||||
|
||||
MANDATORY VALIDATION RULE: Before declaring any Lisp code edit complete, you MUST call the `:validate-lisp` tool with the proposed code. If the tool returns `:status :error`, read the `:reason` and `:failed` fields, fix the defect, and re-validate. You are strictly forbidden from relying on your own paren-balancing or syntax intuition.
|
||||
|
||||
PROVIDER RULE: Always use the default cascade provider unless a specific model or capability is required for the task."
|
||||
assistant-name global-context tool-belt system-logs)))
|
||||
(let* ((thought (probabilistic-call raw-prompt :system-prompt system-prompt :context context))
|
||||
(cleaned (strip-markdown thought))
|
||||
(meta (proto-get context :meta))
|
||||
(source (proto-get meta :source)))
|
||||
(harness-log "THINK: raw cleaned = ~a" (subseq cleaned 0 (min 100 (length cleaned))))
|
||||
(if (and cleaned (stringp cleaned))
|
||||
(let ((*read-eval* nil))
|
||||
(if (and (> (length cleaned) 0) (char= (char cleaned 0) #\())
|
||||
(handler-case
|
||||
(let ((parsed (read-from-string cleaned)))
|
||||
(harness-log "THINK: parsed = ~a" parsed)
|
||||
(let ((parsed-normalized (normalize-plist-keywords parsed))
|
||||
(type (proto-get parsed :TYPE))
|
||||
(target (or (proto-get parsed :TARGET) (proto-get parsed :target))))
|
||||
(cond ((member type '(:REQUEST :EVENT :STATUS :RESPONSE))
|
||||
(unless (proto-get parsed :target) (setf (getf parsed :target) (or source :CLI)))
|
||||
parsed-normalized)
|
||||
((or (eq target :TOOL) (eq target :tool) (getf parsed :TOOL) (getf parsed :tool)
|
||||
(and (listp parsed) (listp (car parsed)) (keywordp (caar parsed))))
|
||||
(list :TYPE :REQUEST :TARGET :TOOL :PAYLOAD (normalize-plist-keywords parsed)))
|
||||
(t (list :TYPE :REQUEST :TARGET (or source :CLI) :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))))
|
||||
(error (c) (harness-log "THINK ERROR: ~a" c) (list :TYPE :REQUEST :TARGET (or source :CLI) :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))
|
||||
(list :TYPE :REQUEST :TARGET (or source :CLI) :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))
|
||||
thought)))))
|
||||
|
||||
(defun deterministic-verify (proposed-action context)
|
||||
"Iterates through all skill deterministic-gates sorted by priority."
|
||||
(let ((current-action proposed-action)
|
||||
(skills nil))
|
||||
(maphash (lambda (name skill) (declare (ignore name)) (when (skill-deterministic-fn skill) (push skill skills))) *skills-registry*)
|
||||
(setf skills (sort skills #'> :key #'skill-priority))
|
||||
(dolist (skill skills)
|
||||
(let ((trigger (skill-trigger-fn skill))
|
||||
(gate (skill-deterministic-fn skill)))
|
||||
(when (or (null trigger) (ignore-errors (funcall trigger context)))
|
||||
(let ((next-action (funcall gate current-action context)))
|
||||
(let ((original-type (proto-get current-action :type)))
|
||||
(when (and (listp next-action)
|
||||
(member (proto-get next-action :type) '(:LOG :EVENT :log :event))
|
||||
(or (not (member original-type '(:LOG :EVENT :log :event)))
|
||||
(not (eq next-action current-action))))
|
||||
(harness-log "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill))
|
||||
(return-from deterministic-verify next-action)))
|
||||
(setf current-action next-action)))))
|
||||
current-action))
|
||||
|
||||
(defun reason-gate (signal)
|
||||
"Unified Stage: Combines Probabilistic proposals and Deterministic verification."
|
||||
(let* ((type (proto-get signal :type))
|
||||
(payload (proto-get signal :payload))
|
||||
(sensor (proto-get payload :sensor)))
|
||||
(unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message)))
|
||||
(return-from reason-gate signal))
|
||||
(let ((candidate (think signal)))
|
||||
(harness-log "REASON: candidate = ~a" (type-of candidate))
|
||||
(if (and candidate (listp candidate)
|
||||
(or (keywordp (car candidate)) (eq (car candidate) 'TYPE) (eq (car candidate) 'type)))
|
||||
(setf (getf signal :approved-action) (deterministic-verify candidate signal))
|
||||
(progn
|
||||
(harness-log "REASON: Invalid candidate type ~a, dropping" (type-of candidate))
|
||||
(setf (getf signal :approved-action) nil)))
|
||||
(setf (getf signal :status) :reasoned)
|
||||
signal)))
|
||||
@@ -1,323 +0,0 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun COSINE-SIMILARITY (v1 v2)
|
||||
"Computes the cosine similarity between two vectors.
|
||||
Both arguments should be sequences of numbers. Returns a value between -1.0 and 1.0."
|
||||
(let ((len1 (length v1)) (len2 (length v2)))
|
||||
(if (or (zerop len1) (zerop len2))
|
||||
0.0
|
||||
(let ((dot-product 0.0d0)
|
||||
(norm1 0.0d0)
|
||||
(norm2 0.0d0))
|
||||
(let ((len (min len1 len2)))
|
||||
(dotimes (i len)
|
||||
(let ((x (coerce (elt v1 i) 'double-float)))
|
||||
(let ((y (coerce (elt v2 i) 'double-float)))
|
||||
(incf dot-product (* x y))
|
||||
(incf norm1 (* x x))
|
||||
(incf norm2 (* y y))))))
|
||||
(if (or (zerop norm1) (zerop norm2))
|
||||
0.0
|
||||
(/ dot-product (sqrt (* norm1 norm2))))))))
|
||||
(defun VAULT-MASK-STRING (s) "[MASKED]") ; Stub
|
||||
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
|
||||
|
||||
|
||||
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn)
|
||||
|
||||
(defvar *skill-catalog* (make-hash-table :test 'equal)
|
||||
"A stateful tracking table for all skill files discovered in the environment.")
|
||||
|
||||
(defstruct skill-entry
|
||||
filename
|
||||
(status :discovered) ;; :discovered, :loading, :ready, :failed
|
||||
error-log
|
||||
(load-time 0))
|
||||
|
||||
(defun find-triggered-skill (context)
|
||||
"Returns the highest priority skill whose trigger matches context AND has a probabilistic prompt."
|
||||
(let ((triggered nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (and (skill-probabilistic-prompt skill)
|
||||
(ignore-errors (funcall (skill-trigger-fn skill) context)))
|
||||
(push skill triggered)))
|
||||
*skills-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
|
||||
(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic)
|
||||
"Registers a new skill into the global registry."
|
||||
`(setf (gethash (string-downcase (string ,name)) *skills-registry*)
|
||||
(make-skill :name (string-downcase (string ,name))
|
||||
:priority (or ,priority 10)
|
||||
:dependencies ',dependencies
|
||||
:trigger-fn ,trigger
|
||||
:probabilistic-prompt ,probabilistic
|
||||
:deterministic-fn ,deterministic)))
|
||||
|
||||
(defun resolve-skill-dependencies (skill-name)
|
||||
"Recursively resolves dependencies for a given skill name."
|
||||
(let ((resolved nil) (seen nil))
|
||||
(labels ((visit (name)
|
||||
(unless (member name seen :test #'equal)
|
||||
(push name seen)
|
||||
(let ((skill (gethash (string-downcase (string name)) *skills-registry*)))
|
||||
(when skill
|
||||
(dolist (dep (skill-dependencies skill))
|
||||
(visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name)
|
||||
(nreverse resolved))))
|
||||
|
||||
(defun parse-skill-metadata (filepath)
|
||||
"Extracts ID and DEPENDS_ON tags using robust regex scanning."
|
||||
(let ((dependencies nil)
|
||||
(id nil)
|
||||
(content (uiop:read-file-string filepath)))
|
||||
;; Extract ID
|
||||
(multiple-value-bind (match regs)
|
||||
(ppcre:scan-to-strings "(?im:^:ID:\\s*([^\\s\\r\\n]+))" content)
|
||||
(when match (setf id (aref regs 0))))
|
||||
;; Extract all DEPENDS_ON lines
|
||||
(ppcre:do-register-groups (deps-string)
|
||||
("(?im:^#\\+DEPENDS_ON:\\s*(.*))" content)
|
||||
(let ((deps (ppcre:split "\\s+" (string-trim " " deps-string))))
|
||||
(setf dependencies (append dependencies (mapcar (lambda (s) (string-trim "[] " s)) deps)))))
|
||||
(values id (remove-if (lambda (s) (= 0 (length s))) dependencies))))
|
||||
|
||||
(defun topological-sort-skills (skills-dir)
|
||||
"Returns a list of skill filepaths sorted by dependency (dependencies first)."
|
||||
(let ((files (uiop:directory-files skills-dir "org-skill-*.org"))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
(id-to-file (make-hash-table :test 'equal))
|
||||
(result nil)
|
||||
(visited (make-hash-table :test 'equal))
|
||||
(stack (make-hash-table :test 'equal)))
|
||||
(dolist (file files)
|
||||
(let ((filename (pathname-name file)))
|
||||
(multiple-value-bind (id deps) (parse-skill-metadata file)
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
(when id (setf (gethash (string-downcase id) id-to-file) file))
|
||||
(setf (gethash (string-downcase filename) adj) deps))))
|
||||
(labels ((visit (file)
|
||||
(let* ((filename (pathname-name file))
|
||||
(node-key (string-downcase filename)))
|
||||
(unless (gethash node-key visited)
|
||||
(setf (gethash node-key stack) t)
|
||||
(dolist (dep (gethash node-key adj))
|
||||
(let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep)))
|
||||
(dep-key (string-downcase (if is-id-p (subseq dep 3) dep)))
|
||||
(dep-file (if is-id-p
|
||||
(gethash dep-key id-to-file)
|
||||
(or (gethash dep-key id-to-file)
|
||||
(gethash dep-key name-to-file)))))
|
||||
(when dep-file
|
||||
(let ((dep-filename (pathname-name dep-file)))
|
||||
(if (gethash (string-downcase dep-filename) stack)
|
||||
(error "Circular dependency detected: ~a -> ~a" filename dep-filename)
|
||||
(visit dep-file))))))
|
||||
(setf (gethash node-key stack) nil)
|
||||
(setf (gethash node-key visited) t)
|
||||
(push file result)))))
|
||||
(let ((filenames (sort (mapcar #'pathname-name files) #'string<)))
|
||||
(dolist (name filenames)
|
||||
(let ((file (gethash (string-downcase name) name-to-file)))
|
||||
(when file (visit file)))))
|
||||
(nreverse result))))
|
||||
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
"Checks if a string contains valid, readable Common Lisp forms.
|
||||
Delegates to the Lisp Validator skill when available; falls back to a basic
|
||||
reader check during early boot before the validator skill is loaded."
|
||||
(let ((result
|
||||
(if (fboundp 'lisp-validator-validate)
|
||||
(lisp-validator-validate code-string :strict nil)
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof) until (eq form :eof)))
|
||||
(list :status :success))
|
||||
(error (c)
|
||||
(list :status :error :reason (format nil "~a" c)))))))
|
||||
(if (eq (getf result :status) :success)
|
||||
(values t nil)
|
||||
(values nil (or (getf result :reason) "Lisp Validator rejected code.")))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses and evaluates Lisp blocks with :tangle directives from an Org file.
|
||||
Only loads blocks that specify a .lisp tangle target, ignoring tests and examples."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(setf (gethash skill-base-name *skill-catalog*) entry)
|
||||
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil)
|
||||
(collect-this-block nil)
|
||||
(lisp-code "")
|
||||
(pkg-name (intern (string-upcase (format nil "OPENCORTEX.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond ((uiop:string-prefix-p "#+begin_src lisp" (string-downcase clean-line))
|
||||
(setf in-lisp-block t)
|
||||
;; Only collect blocks with a :tangle directive pointing to a
|
||||
;; runtime .lisp file (exclude tests and :tangle no)
|
||||
(let ((tl (string-downcase clean-line)))
|
||||
(setf collect-this-block
|
||||
(and (search ":tangle" tl)
|
||||
(not (search ":tangle no" tl))
|
||||
(search ".lisp" tl)
|
||||
(not (search "tests/" tl))
|
||||
(not (search "test/" tl))))))
|
||||
((uiop:string-prefix-p "#+end_src" (string-downcase clean-line))
|
||||
(setf in-lisp-block nil)
|
||||
(setf collect-this-block nil))
|
||||
((and in-lisp-block collect-this-block)
|
||||
(unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":END:" (string-upcase clean-line)))
|
||||
(setf lisp-code (concatenate 'string lisp-code line (string #\Newline))))))))
|
||||
|
||||
(if (= (length lisp-code) 0)
|
||||
(progn (setf (skill-entry-status entry) :ready) t)
|
||||
(progn
|
||||
(multiple-value-bind (valid-p err) (validate-lisp-syntax lisp-code)
|
||||
(unless valid-p (error "Syntax Error: ~a" err)))
|
||||
(harness-log "HARNESS: Jailing skill '~a' in package ~a" skill-base-name pkg-name)
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl))))
|
||||
(use-package :opencortex new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
||||
(setf (skill-entry-status entry) :ready)
|
||||
t)))
|
||||
(error (c)
|
||||
(let ((msg (format nil "~a" c)))
|
||||
(harness-log "LOADER ERROR in skill '~a': ~a" skill-base-name msg)
|
||||
(setf (skill-entry-status entry) :failed)
|
||||
(setf (skill-entry-error-log entry) msg)
|
||||
nil)))))
|
||||
|
||||
(defun load-skill-with-timeout (filepath timeout-seconds)
|
||||
"Loads a skill Org file with a hard execution timeout."
|
||||
(let* ((finished nil)
|
||||
(thread (bt:make-thread (lambda ()
|
||||
(if (load-skill-from-org filepath)
|
||||
(setf finished t)
|
||||
(setf finished :error)))
|
||||
:name (format nil "loader-~a" (pathname-name filepath))))
|
||||
(start-time (get-internal-real-time))
|
||||
(timeout-units (truncate (* timeout-seconds internal-time-units-per-second))))
|
||||
(loop
|
||||
(when (eq finished t) (return :success))
|
||||
(when (eq finished :error) (return :error))
|
||||
(unless (bt:thread-alive-p thread) (return :error))
|
||||
(when (> (- (get-internal-real-time) start-time) timeout-units)
|
||||
(harness-log "HARNESS: Timing out skill ~a..." (pathname-name filepath))
|
||||
#+sbcl (sb-thread:terminate-thread thread)
|
||||
#-sbcl (bt:destroy-thread thread)
|
||||
(return :timeout))
|
||||
(sleep 0.05))))
|
||||
|
||||
(defun initialize-all-skills ()
|
||||
"Scans the directory defined by SKILLS_DIR and hot-loads skills using topological order."
|
||||
(let* ((env-path (uiop:getenv "SKILLS_DIR"))
|
||||
(skills-dir-str (or env-path (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))
|
||||
(resolved-path (context-resolve-path skills-dir-str))
|
||||
(skills-dir (if resolved-path (uiop:ensure-directory-pathname resolved-path) nil)))
|
||||
|
||||
(unless (and skills-dir (uiop:directory-exists-p skills-dir))
|
||||
(harness-log "HARNESS ERROR: Skills directory not found: ~a" skills-dir-str)
|
||||
(return-from initialize-all-skills nil))
|
||||
|
||||
(let ((sorted-files (topological-sort-skills skills-dir)))
|
||||
(let* ((mandatory-env (uiop:getenv "MANDATORY_SKILLS"))
|
||||
(mandatory-skills (if mandatory-env
|
||||
(mapcar (lambda (s) (string-trim '(#\Space #\" #\') s))
|
||||
(uiop:split-string mandatory-env :separator '( #\,)))
|
||||
'("org-skill-policy" "org-skill-bouncer"))))
|
||||
(dolist (req mandatory-skills)
|
||||
(unless (member req sorted-files :key #'pathname-name :test #'string-equal)
|
||||
(error "BOOT FAILURE: Mandatory skill '~a' not found in skills directory: ~a" req (uiop:native-namestring skills-dir))))
|
||||
|
||||
(harness-log "==================================================")
|
||||
(harness-log " LOADER: Initializing ~a skills..." (length sorted-files))
|
||||
|
||||
(dolist (file sorted-files)
|
||||
(let* ((skill-name (pathname-name file))
|
||||
(is-mandatory (member skill-name mandatory-skills :test #'string-equal)))
|
||||
(harness-log " LOADER: Loading ~a..." skill-name)
|
||||
(let ((status (load-skill-with-timeout file 5)))
|
||||
(unless (eq status :success)
|
||||
(if is-mandatory
|
||||
(error "BOOT FAILURE: Mandatory skill '~a' failed to load (Status: ~a)." skill-name status)
|
||||
(harness-log "LOADER WARNING: Skill '~a' failed to load." skill-name))))))
|
||||
|
||||
(let ((ready 0) (failed 0))
|
||||
(maphash (lambda (k v)
|
||||
(declare (ignore k))
|
||||
(if (eq (skill-entry-status v) :ready) (incf ready) (incf failed)))
|
||||
*skill-catalog*)
|
||||
(harness-log " LOADER: Boot Complete. [Ready: ~a] [Failed: ~a]" ready failed)
|
||||
(harness-log "==================================================")
|
||||
(values ready failed))))))
|
||||
|
||||
(defun generate-tool-belt-prompt ()
|
||||
"Aggregates all registered cognitive tools into a descriptive prompt."
|
||||
(let ((output (format nil "AVAILABLE TOOLS:
|
||||
You can call tools by returning a Lisp plist: (:target :tool :action :call :tool <name> :args (...))
|
||||
|
||||
EXAMPLES:
|
||||
(:target :tool :action :call :tool \"eval\" :args (:code \"(+ 1 1)\"))
|
||||
(:target :tool :action :call :tool \"grep-search\" :args (:pattern \"autonomousty\"))
|
||||
(:target :tool :action :call :tool \"shell\" :args (:cmd \"ls -la\"))
|
||||
|
||||
---
|
||||
" )))
|
||||
(maphash (lambda (name tool)
|
||||
(setf output (concatenate 'string output
|
||||
(format nil "- ~a: ~a~% Parameters: ~s~%~%"
|
||||
name
|
||||
(cognitive-tool-description tool)
|
||||
(cognitive-tool-parameters tool)))))
|
||||
*cognitive-tools*)
|
||||
output))
|
||||
|
||||
(def-cognitive-tool :eval "Evaluates raw Common Lisp code in the harness image. Use this for complex calculations or internal state inspection."
|
||||
((:code :type :string :description "The Lisp code to evaluate"))
|
||||
:guard (lambda (args context)
|
||||
(declare (ignore context))
|
||||
(let ((code (getf args :code)))
|
||||
(let ((harness-pkg (find-package :opencortex.skills.org-skill-lisp-validator)))
|
||||
(if harness-pkg
|
||||
(uiop:symbol-call :opencortex.skills.org-skill-lisp-validator :lisp-validator-validate code)
|
||||
t))))
|
||||
:body (lambda (args)
|
||||
(let ((code (getf args :code)))
|
||||
(handler-case (let ((result (eval (read-from-string code))))
|
||||
(format nil "~s" result))
|
||||
(error (c) (format nil "ERROR: ~a" c))))))
|
||||
|
||||
(def-cognitive-tool :grep-search "Searches for a pattern in the project files."
|
||||
((:pattern :type :string :description "The regex pattern to search for")
|
||||
(:dir :type :string :description "Directory to search in (default is project root)"))
|
||||
:body (lambda (args)
|
||||
(let ((pattern (getf args :pattern))
|
||||
(dir (or (getf args :dir) (uiop:getenv "MEMEX_DIR"))))
|
||||
(uiop:run-program (list "grep" "-r" "-n" "--exclude-dir=node_modules" pattern dir)
|
||||
:output :string :ignore-error-status t))))
|
||||
|
||||
(def-cognitive-tool :shell "Executes a shell command on the local machine. Use this for file operations, system checks, or running tests."
|
||||
((:cmd :type :string :description "The full bash command to execute"))
|
||||
:guard (lambda (args context)
|
||||
(declare (ignore context))
|
||||
(let ((cmd (getf args :cmd)))
|
||||
(not (or (search "rm -rf /" cmd) (search ":(){ :|:& };:" cmd)))))
|
||||
:body (lambda (args)
|
||||
(let ((cmd (getf args :cmd)))
|
||||
(multiple-value-bind (out err code)
|
||||
(uiop:run-program (list "bash" "-c" cmd) :output :string :error-output :string :ignore-error-status t)
|
||||
(format nil "EXIT-CODE: ~a~%~%STDOUT:~%~a~%~%STDERR:~%~a" code out err)))))
|
||||
@@ -1,160 +0,0 @@
|
||||
(in-package :cl-user)
|
||||
(defpackage :opencortex.tui
|
||||
(:use :cl :croatoan)
|
||||
(:export :main))
|
||||
(in-package :opencortex.tui)
|
||||
|
||||
(defvar *daemon-host* "127.0.0.1")
|
||||
(defvar *daemon-port* 9105)
|
||||
(defvar *socket* nil)
|
||||
(defvar *stream* nil)
|
||||
(defvar *chat-history* (list))
|
||||
(defvar *status-text* "Connecting...")
|
||||
(defvar *input-buffer* (make-array 0 :element-type 'char :fill-pointer 0 :adjustable t))
|
||||
(defvar *is-running* t)
|
||||
(defvar *queue-lock* (bt:make-lock))
|
||||
(defvar *incoming-msgs* nil)
|
||||
|
||||
(defun enqueue-msg (msg)
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(push msg *incoming-msgs*)))
|
||||
|
||||
(defun dequeue-msgs ()
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(let ((msgs (nreverse *incoming-msgs*)))
|
||||
(setf *incoming-msgs* nil)
|
||||
msgs)))
|
||||
|
||||
(defun clean-keywords (msg)
|
||||
(if (listp msg)
|
||||
(let ((clean nil))
|
||||
(loop for (k v) on msg by #'cddr
|
||||
do (push (intern (string k) :keyword) clean)
|
||||
(push v clean))
|
||||
(nreverse clean))
|
||||
msg))
|
||||
|
||||
(defun format-payload (payload)
|
||||
"Extracts human-readable text from a protocol payload, handling nested tool calls."
|
||||
(let* ((action (getf payload :ACTION))
|
||||
(text (getf payload :TEXT))
|
||||
(msg (getf payload :MESSAGE))
|
||||
(tool (getf payload :TOOL))
|
||||
(prompt (getf payload :PROMPT))
|
||||
(args (getf payload :ARGS))
|
||||
(result (getf payload :RESULT)))
|
||||
(cond (text text)
|
||||
(msg msg)
|
||||
((eq action :MESSAGE) (getf payload :TEXT))
|
||||
((and tool prompt) (format nil "THOUGHT [~a]: ~a" tool prompt))
|
||||
((and tool args)
|
||||
(let ((inner-prompt (or (getf args :PROMPT) (getf args :TEXT))))
|
||||
(if inner-prompt
|
||||
(format nil "THOUGHT [~a]: ~a" tool inner-prompt)
|
||||
(format nil "CALL [~a] (ARGS: ~s)" tool args))))
|
||||
(result (format nil "RESULT: ~a" result))
|
||||
(t (format nil "~s" payload)))))
|
||||
|
||||
(defun listen-thread ()
|
||||
(loop while *is-running* do
|
||||
(handler-case
|
||||
(when (and *stream* (open-stream-p *stream*))
|
||||
(let ((raw-msg (opencortex:read-framed-message *stream*)))
|
||||
(unless (member raw-msg '(:eof :error))
|
||||
(let* ((msg (clean-keywords raw-msg))
|
||||
(type (or (getf msg :TYPE) (getf msg :type)))
|
||||
(payload (or (getf msg :PAYLOAD) (getf msg :payload))))
|
||||
(cond ((and (listp msg) (eq type :EVENT))
|
||||
(let ((action (or (getf payload :ACTION) (getf payload :action)))
|
||||
(text (or (getf payload :TEXT) (getf payload :text) (getf payload :MESSAGE) (getf payload :message))))
|
||||
(cond ((eq action :handshake) (setf *status-text* "Ready"))
|
||||
(text (enqueue-msg (format nil "SYSTEM: ~a" text))))))
|
||||
((and (listp msg) (eq type :STATUS))
|
||||
(setf *status-text* (format nil "[Scribe: ~a] [Gardener: ~a]"
|
||||
(or (getf msg :SCRIBE) (getf msg :scribe))
|
||||
(or (getf msg :GARDENER) (getf msg :gardener)))))
|
||||
((and (listp msg) (member type '(:REQUEST :RESPONSE :LOG)))
|
||||
(let ((formatted (format-payload payload)))
|
||||
(when formatted (enqueue-msg formatted))))
|
||||
((and (listp msg) (eq type :EVENT) (eq (getf payload :SENSOR) :TOOL-OUTPUT))
|
||||
(let ((formatted (format-payload payload)))
|
||||
(when formatted (enqueue-msg formatted))))
|
||||
(t (harness-log "TUI: Ignored unknown type ~a" type)))))
|
||||
(when (eq raw-msg :eof) (setf *is-running* nil))
|
||||
(when (eq raw-msg :error) (setf *status-text* "Protocol Error"))))
|
||||
(error (c) (setf *status-text* (format nil "Net Error: ~a" c)) (setf *is-running* nil)))
|
||||
(sleep 0.05)))
|
||||
|
||||
(defun main ()
|
||||
(handler-case
|
||||
(setf *socket* (usocket:socket-connect *daemon-host* *daemon-port*))
|
||||
(error (e) (format t "Error connecting: ~a~%" e) (return-from main)))
|
||||
(setf *stream* (usocket:socket-stream *socket*))
|
||||
(bt:make-thread #'listen-thread :name "tui-listener")
|
||||
|
||||
(unwind-protect
|
||||
(with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t :cursor-visible t)
|
||||
(let* ((h (height scr))
|
||||
(w (width scr))
|
||||
(chat-win (make-instance 'window :height (- h 2) :width w :position (list 0 0)))
|
||||
(status-win (make-instance 'window :height 1 :width w :position (list (- h 2) 0)))
|
||||
(input-win (make-instance 'window :height 1 :width w :position (list (- h 1) 0)))
|
||||
(last-status nil))
|
||||
|
||||
(setf (function-keys-enabled-p input-win) t)
|
||||
(setf (input-blocking input-win) nil)
|
||||
|
||||
(loop while *is-running* do
|
||||
;; 1. Handle incoming messages
|
||||
(let ((new-msgs (dequeue-msgs)))
|
||||
(when new-msgs
|
||||
(dolist (msg new-msgs)
|
||||
(push msg *chat-history*)
|
||||
(setf *chat-history* (subseq *chat-history* 0 (min (length *chat-history*) 500))))
|
||||
|
||||
(clear chat-win)
|
||||
(let ((line-num 0))
|
||||
(dolist (m (reverse (subseq *chat-history* 0 (min (length *chat-history*) (- h 3)))))
|
||||
(add-string chat-win m :y line-num :x 0)
|
||||
(incf line-num)))
|
||||
(refresh chat-win)))
|
||||
|
||||
;; 2. Render Status Bar ONLY if changed
|
||||
(unless (equal *status-text* last-status)
|
||||
(clear status-win)
|
||||
(add-string status-win *status-text* :attributes '(:reverse))
|
||||
(refresh status-win)
|
||||
(setf last-status *status-text*))
|
||||
|
||||
;; 3. Handle Keyboard Input
|
||||
(let* ((event (get-wide-event input-win))
|
||||
(ch (and event (typep event 'event) (event-key event))))
|
||||
(when ch
|
||||
(cond
|
||||
((or (eq ch #\Newline) (eq ch #\Return))
|
||||
(let ((cmd (coerce *input-buffer* 'string)))
|
||||
(setf (fill-pointer *input-buffer*) 0)
|
||||
(when (> (length cmd) 0)
|
||||
;; Local Echo
|
||||
(enqueue-msg (concatenate 'string "> " cmd))
|
||||
;; Send to Brain
|
||||
(let ((framed (opencortex:frame-message (list :TYPE :EVENT
|
||||
:META (list :SOURCE :tui :SESSION-ID "default")
|
||||
:PAYLOAD (list :SENSOR :user-input :TEXT cmd)))))
|
||||
(format *stream* "~a" framed)
|
||||
(finish-output *stream*)))
|
||||
(when (string= cmd "/exit") (setf *is-running* nil))))
|
||||
((or (eq ch :backspace) (eq ch #\Backspace) (eq ch #\Rubout) (eq ch #\Del))
|
||||
(when (> (length *input-buffer*) 0)
|
||||
(decf (fill-pointer *input-buffer*))))
|
||||
((characterp ch)
|
||||
(vector-push-extend ch *input-buffer*))))
|
||||
|
||||
(clear input-win)
|
||||
(add-string input-win (concatenate 'string "> " (coerce *input-buffer* 'string)))
|
||||
(move input-win 0 (+ 2 (length *input-buffer*)))
|
||||
(refresh input-win))
|
||||
|
||||
(sleep 0.02))))
|
||||
(setf *is-running* nil)
|
||||
(when *socket* (usocket:socket-close *socket*))))
|
||||
122
lisp/core-communication.lisp
Normal file
122
lisp/core-communication.lisp
Normal file
@@ -0,0 +1,122 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *actuator-registry* (make-hash-table :test 'equalp)
|
||||
"Global registry mapping target keywords to their physical actuator functions.")
|
||||
|
||||
(defun actuator-register (name fn)
|
||||
"Registers an actuator function. Actuators receive: (ACTION CONTEXT)."
|
||||
(let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword))))
|
||||
(setf (gethash key *actuator-registry*) fn)))
|
||||
|
||||
(defun protocol-message-sanitize (msg)
|
||||
"Recursively strips non-serializable objects from a protocol plist."
|
||||
(if (and msg (listp msg))
|
||||
(let ((clean nil))
|
||||
(loop for (k v) on msg by #'cddr
|
||||
do (unless (member k '(:reply-stream :socket :stream))
|
||||
(push k clean)
|
||||
(push (if (listp v) (protocol-message-sanitize v) v) clean)))
|
||||
(nreverse clean))
|
||||
msg))
|
||||
|
||||
(defun frame-message (msg)
|
||||
"Serializes a message plist and prefixes it with a 6-character hex length."
|
||||
(let* ((sanitized (protocol-message-sanitize msg))
|
||||
(payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized)))
|
||||
(len (length payload)))
|
||||
(format nil "~6,'0x~a" len payload)))
|
||||
|
||||
(defun read-framed-message (stream)
|
||||
"Reads a hex-length prefixed S-expression from the stream securely."
|
||||
(let ((length-buffer (make-string 6)))
|
||||
(handler-case
|
||||
(progn
|
||||
(loop for char = (peek-char nil stream nil :eof)
|
||||
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return)))
|
||||
do (read-char stream))
|
||||
(let ((count (read-sequence length-buffer stream)))
|
||||
(if (< count 6)
|
||||
:eof
|
||||
(let ((len (ignore-errors (parse-integer length-buffer :radix 16))))
|
||||
(if (not len)
|
||||
:error
|
||||
(let ((msg-buffer (make-string len)))
|
||||
(read-sequence msg-buffer stream)
|
||||
(let ((*read-eval* nil))
|
||||
(handler-case (read-from-string msg-buffer)
|
||||
(error () :error)))))))))
|
||||
(error () :error))))
|
||||
|
||||
(defvar *daemon-socket* nil)
|
||||
|
||||
(defun client-handle-connection (socket)
|
||||
"Handles a single TUI/CLI client connection in a dedicated thread."
|
||||
(let ((stream (usocket:socket-stream socket)))
|
||||
(handler-case
|
||||
(progn
|
||||
(format stream "~a" (frame-message (make-hello-message "0.2.0")))
|
||||
(finish-output stream)
|
||||
(loop
|
||||
(let ((msg (read-framed-message stream)))
|
||||
(cond
|
||||
((eq msg :eof) (return))
|
||||
((eq msg :error) (return))
|
||||
((eq (getf msg :type) :health-check)
|
||||
(let ((health-msg (list :type :health-response
|
||||
:status (or (and (boundp 'passepartout::*system-health*)
|
||||
(symbol-value 'passepartout::*system-health*))
|
||||
:unknown)
|
||||
:checked-p (or (and (boundp 'passepartout::*health-check-ran*)
|
||||
(symbol-value 'passepartout::*health-check-ran*))
|
||||
nil))))
|
||||
(format stream "~a" (frame-message health-msg))
|
||||
(finish-output stream)))
|
||||
(t (inject-stimulus msg :stream stream))))))
|
||||
(error (c) (log-message "CLIENT ERROR: ~a" c)))
|
||||
(ignore-errors (usocket:socket-close socket))))
|
||||
|
||||
(defun start-daemon (&key (port 9105))
|
||||
"Starts the network listener for TUI/CLI clients."
|
||||
(setf *daemon-socket* (usocket:socket-listen "127.0.0.1" port :reuse-address t))
|
||||
(log-message "DAEMON: Listening on localhost:~a" port)
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(let ((client-socket (usocket:socket-accept *daemon-socket*)))
|
||||
(when client-socket
|
||||
(bt:make-thread (lambda () (client-handle-connection client-socket))
|
||||
:name "passepartout-client-handler")))))
|
||||
:name "passepartout-server-listener"))
|
||||
|
||||
(defun make-hello-message (version)
|
||||
"Constructs the standard HELLO handshake message."
|
||||
(list :TYPE :EVENT
|
||||
:PAYLOAD (list :ACTION :handshake
|
||||
:VERSION version
|
||||
:CAPABILITIES '(:AUTH :ORG-AST))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun protocol-schema-validate (msg)
|
||||
"Strict structural validation for incoming protocol messages."
|
||||
(unless (listp msg) (error "Message must be a plist"))
|
||||
(let ((type (proto-get msg :type)))
|
||||
(unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS))
|
||||
(error "Invalid message type '~a'" type))
|
||||
t))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-communication-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:communication-protocol-suite))
|
||||
(in-package :passepartout-communication-tests)
|
||||
|
||||
(def-suite communication-protocol-suite :description "Communication Protocol Suite")
|
||||
(in-suite communication-protocol-suite)
|
||||
|
||||
(test test-framing
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake)))
|
||||
(framed (frame-message msg)))
|
||||
(is (string= "00002C" (string-upcase (subseq framed 0 6))))))
|
||||
@@ -1,6 +1,6 @@
|
||||
(in-package :opencortex)
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun context-query-store (&key tag todo-state type)
|
||||
(defun context-query (&key tag todo-state type)
|
||||
"Filters the Memory based on tags, todo states, or types."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
@@ -13,16 +13,16 @@
|
||||
*memory*)
|
||||
results))
|
||||
|
||||
(defun context-get-active-projects ()
|
||||
(defun context-active-projects ()
|
||||
"Returns headlines tagged as 'project' that are not yet marked DONE."
|
||||
(remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE"))
|
||||
(context-query-store :tag "project" :type :HEADLINE)))
|
||||
(context-query :tag "project" :type :HEADLINE)))
|
||||
|
||||
(defun context-get-recent-completed-tasks ()
|
||||
(defun context-recent-tasks ()
|
||||
"Retrieves recently finished tasks from the store."
|
||||
(context-query-store :todo-state "DONE" :type :HEADLINE))
|
||||
(context-query :todo-state "DONE" :type :HEADLINE))
|
||||
|
||||
(defun context-list-all-skills ()
|
||||
(defun context-skill-list ()
|
||||
"Provides a sorted overview of currently loaded system capabilities."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (name skill)
|
||||
@@ -31,22 +31,22 @@
|
||||
*skills-registry*)
|
||||
(sort results #'> :key (lambda (x) (getf x :priority)))))
|
||||
|
||||
(defun context-get-skill-source (skill-name)
|
||||
(defun context-skill-source (skill-name)
|
||||
"Reads the raw literate source of a specific skill for inspection."
|
||||
(let* ((filename (format nil "~a.org" skill-name))
|
||||
(skills-dir-str (or (uiop:getenv "SKILLS_DIR") (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))
|
||||
(skills-dir (uiop:ensure-directory-pathname (context-resolve-path skills-dir-str)))
|
||||
(full-path (merge-pathnames filename skills-dir)))
|
||||
(data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname))))))
|
||||
(org-dir (merge-pathnames "org/" data-dir))
|
||||
(full-path (merge-pathnames filename org-dir)))
|
||||
(if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil)))
|
||||
|
||||
(defun context-get-system-logs (&optional limit)
|
||||
(defun context-logs (&optional limit)
|
||||
"Retrieves the most recent lines from the harness's internal log."
|
||||
(let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20)))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(let ((count (min log-limit (length *system-logs*))))
|
||||
(subseq *system-logs* 0 count)))))
|
||||
|
||||
(defun context-render-to-org (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil))
|
||||
(defun context-object-render (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil))
|
||||
"Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model."
|
||||
(let* ((id (org-object-id obj))
|
||||
(is-foveal (equal id foveal-id))
|
||||
@@ -60,9 +60,6 @@
|
||||
(cosine-similarity foveal-vector obj-vector)
|
||||
0.0))
|
||||
(is-semantically-relevant (>= similarity threshold))
|
||||
;; We always render depth 1 and 2 (Projects and main tasks).
|
||||
;; We always render the foveal node and its immediate children.
|
||||
;; We render deeper nodes ONLY if they are semantically relevant.
|
||||
(should-render (or (<= depth 2) is-foveal is-semantically-relevant))
|
||||
(output ""))
|
||||
|
||||
@@ -72,25 +69,22 @@
|
||||
(setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity))))
|
||||
(setf output (concatenate 'string output (format nil ":END:~%")))
|
||||
|
||||
;; Only include full body content if this is the Foveal focus or highly relevant
|
||||
(when (and content (or is-foveal is-semantically-relevant))
|
||||
(setf output (concatenate 'string output content (string #\Newline))))
|
||||
|
||||
;; Recursively render children
|
||||
(dolist (child-id children)
|
||||
(let ((child-obj (lookup-object child-id)))
|
||||
(when child-obj
|
||||
;; If the current node is Foveal, its children should be rendered (depth effectively resets)
|
||||
(let ((next-foveal (if is-foveal child-id foveal-id)))
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org child-obj
|
||||
(context-object-render child-obj
|
||||
:depth (1+ depth)
|
||||
:foveal-id next-foveal
|
||||
:semantic-threshold threshold
|
||||
:foveal-vector foveal-vector))))))))
|
||||
output))
|
||||
|
||||
(defun context-resolve-path (path-string)
|
||||
(defun context-path-resolve (path-string)
|
||||
"Expands environment variables and strips literal quotes from a path string."
|
||||
(let ((path (if (stringp path-string)
|
||||
(string-trim '(#\" #\' #\Space) path-string)
|
||||
@@ -104,16 +98,66 @@
|
||||
result)
|
||||
path)))
|
||||
|
||||
(defun context-assemble-global-awareness (&optional signal)
|
||||
"Produces a high-level skeletal outline of the current Memory for the LLM."
|
||||
(defun context-privacy-filtered-p (obj)
|
||||
"Returns T if an org-object's :TAGS attribute matches bouncer-privacy-tags."
|
||||
(let* ((attrs (org-object-attributes obj))
|
||||
(tags (getf attrs :TAGS))
|
||||
(privacy-tags (and (find-package :passepartout.security-dispatcher)
|
||||
(symbol-value
|
||||
(find-symbol "BOUNCER-PRIVACY-TAGS"
|
||||
:passepartout.security-dispatcher)))))
|
||||
(when (and tags privacy-tags)
|
||||
(let ((tag-list (if (listp tags) tags (list tags))))
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private)
|
||||
(string-equal (string-trim '(#\:) tag)
|
||||
(string-trim '(#\:) private)))
|
||||
privacy-tags))
|
||||
tag-list)))))
|
||||
|
||||
(defun context-awareness-assemble (&optional signal)
|
||||
"Produces a high-level skeletal outline of the current Memory for the LLM.
|
||||
Privacy-filtered objects (matching bouncer-privacy-tags) are excluded."
|
||||
(let* ((foveal-id (or (getf signal :foveal-focus)
|
||||
(ignore-errors (getf (getf signal :payload) :target-id))))
|
||||
(projects (context-get-active-projects))
|
||||
(output "GLOBAL MEMEX AWARENESS (Peripheral Vision):
|
||||
"))
|
||||
(all-projects (context-active-projects))
|
||||
(projects (remove-if #'context-privacy-filtered-p all-projects))
|
||||
(output (format nil "GLOBAL MEMEX AWARENESS (Peripheral Vision):~%")))
|
||||
(if projects
|
||||
(dolist (project projects)
|
||||
(setf output (concatenate 'string output
|
||||
(context-render-to-org project :foveal-id foveal-id))))
|
||||
(context-object-render project :foveal-id foveal-id))))
|
||||
(setf output (concatenate 'string output "No active projects found.~%")))
|
||||
output))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-peripheral-vision-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:vision-suite))
|
||||
(in-package :passepartout-peripheral-vision-tests)
|
||||
|
||||
(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.")
|
||||
(in-suite vision-suite)
|
||||
|
||||
(test test-foveal-rendering
|
||||
(clrhash passepartout::*memory*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node")
|
||||
:raw-content "FOVEAL CONTENT" :contents nil)
|
||||
(:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node")
|
||||
:raw-content "PERIPHERAL CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble (list :foveal-focus "node-foveal"))))
|
||||
(is (search "FOVEAL CONTENT" output))
|
||||
(is (search "* Peripheral Node" output))
|
||||
(is (not (search "PERIPHERAL CONTENT" output))))))
|
||||
|
||||
(test test-awareness-budget
|
||||
(clrhash passepartout::*memory*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil))
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil))
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (search "Project 1" output))
|
||||
(is (search "Project 2" output))))
|
||||
227
lisp/core-defpackage.lisp
Normal file
227
lisp/core-defpackage.lisp
Normal file
@@ -0,0 +1,227 @@
|
||||
(defpackage :passepartout
|
||||
(:use :cl)
|
||||
(:export
|
||||
#:frame-message
|
||||
#:read-framed-message
|
||||
#:PROTO-GET
|
||||
#:LIST-OBJECTS-WITH-ATTRIBUTE
|
||||
#:COSINE-SIMILARITY
|
||||
#:VAULT-MASK-STRING
|
||||
#:*VAULT-MEMORY*
|
||||
#:parse-message
|
||||
#:make-hello-message
|
||||
#:validate-communication-protocol-schema
|
||||
#:start-daemon
|
||||
#:stop-daemon
|
||||
#:log-message
|
||||
#:main
|
||||
#:doctor-run-all
|
||||
#:doctor-main
|
||||
#:doctor-check-dependencies
|
||||
#:doctor-check-env
|
||||
#:register-provider
|
||||
#:system-ready-p
|
||||
#:run-setup-wizard
|
||||
#:skill-gateway-register
|
||||
#:skill-gateway-link
|
||||
#:gateway-manager-main
|
||||
#:ingest-ast
|
||||
#:lookup-object
|
||||
#:list-objects-by-type
|
||||
#:org-id-new
|
||||
#:*memory*
|
||||
#:*history-store*
|
||||
#:org-object
|
||||
#:make-org-object
|
||||
#:org-object-id
|
||||
#:org-object-type
|
||||
#:org-object-attributes
|
||||
#:org-object-parent-id
|
||||
#:org-object-children
|
||||
#:org-object-version
|
||||
#:org-object-last-sync
|
||||
#:org-object-vector
|
||||
#:org-object-content
|
||||
#:org-object-hash
|
||||
#:snapshot-memory
|
||||
#:rollback-memory
|
||||
#:context-query-store
|
||||
#:context-get-active-projects
|
||||
#:context-get-recent-completed-tasks
|
||||
#:context-list-all-skills
|
||||
#:context-get-skill-source
|
||||
#:context-get-system-logs
|
||||
#:context-resolve-path
|
||||
#:context-get-skill-telemetry
|
||||
#:telemetry-track
|
||||
#:context-assemble-global-awareness
|
||||
#:loop-process
|
||||
#:loop-process
|
||||
#:perceive-gate
|
||||
#:probabilistic-gate
|
||||
#:consensus-gate
|
||||
#:act-gate
|
||||
#:reason-gate
|
||||
#:dispatch-gate
|
||||
#:inject-stimulus
|
||||
#:initialize-actuators
|
||||
#:dispatch-action
|
||||
#:register-actuator
|
||||
#:load-skill-from-org
|
||||
#:skill-initialize-all
|
||||
#:load-skill-with-timeout
|
||||
#:topological-sort-skills
|
||||
#:validate-lisp-syntax
|
||||
#:defskill
|
||||
#:*skill-registry*
|
||||
#:skill
|
||||
#:skill-name
|
||||
#:skill-priority
|
||||
#:skill-dependencies
|
||||
#:skill-trigger-fn
|
||||
#:skill-probabilistic-prompt
|
||||
#:skill-deterministic-fn
|
||||
#:def-cognitive-tool
|
||||
#:*cognitive-tool-registry*
|
||||
#:verify-git-clean-p
|
||||
#:engineering-standards-verify-lisp
|
||||
#:engineering-standards-format-lisp
|
||||
#:literate-check-block-balance
|
||||
#:check-tangle-sync
|
||||
#:*tangle-targets*
|
||||
#:utils-org-read-file
|
||||
#:utils-org-write-file
|
||||
#:utils-org-add-headline
|
||||
#:utils-org-set-property
|
||||
#:utils-org-set-todo
|
||||
#:utils-org-find-headline-by-id
|
||||
#:utils-org-find-headline-by-title
|
||||
#:utils-org-generate-id
|
||||
#:utils-org-id-format
|
||||
#:utils-org-ast-to-org
|
||||
#:utils-org-modify
|
||||
#:utils-lisp-validate
|
||||
#:utils-lisp-check-structural
|
||||
#:utils-lisp-check-syntactic
|
||||
#:utils-lisp-check-semantic
|
||||
#:utils-lisp-eval
|
||||
#:utils-lisp-format
|
||||
#:utils-lisp-list-definitions
|
||||
#:utils-lisp-structural-extract
|
||||
#:utils-lisp-structural-wrap
|
||||
#:utils-lisp-structural-inject
|
||||
#:utils-lisp-structural-slurp
|
||||
#:utils-lisp-register
|
||||
#:get-oc-config-dir
|
||||
#:prompt-for
|
||||
#:save-secret
|
||||
#:get-tool-permission
|
||||
#:set-tool-permission
|
||||
#:check-tool-permission-gate
|
||||
#:cognitive-tool
|
||||
#:cognitive-tool-name
|
||||
#:cognitive-tool-description
|
||||
#:cognitive-tool-parameters
|
||||
#:cognitive-tool-guard
|
||||
#:cognitive-tool-body
|
||||
#:*emacs-clients*
|
||||
#:*clients-lock*
|
||||
#:register-emacs-client
|
||||
#:unregister-emacs-client
|
||||
#:ask-probabilistic
|
||||
#:register-probabilistic-backend
|
||||
#:distill-prompt
|
||||
#:*probabilistic-backends*
|
||||
#:*provider-cascade*
|
||||
#:vault-get-secret
|
||||
#:vault-set-secret
|
||||
#:memory-objects-by-attribute
|
||||
#:deterministic-verify
|
||||
#:find-headline-missing-id))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun plist-get (plist key)
|
||||
"Robust plist accessor — checks both :KEY and :key variants."
|
||||
(let* ((s (string key))
|
||||
(up (intern (string-upcase s) :keyword))
|
||||
(dn (intern (string-downcase s) :keyword)))
|
||||
(or (getf plist up) (getf plist dn))))
|
||||
|
||||
(defvar *log-buffer* nil)
|
||||
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
|
||||
(defvar *log-limit* 100)
|
||||
|
||||
(defvar *skill-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded skills.")
|
||||
|
||||
(defvar *telemetry-table* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
|
||||
|
||||
(defun telemetry-track (skill-name duration status)
|
||||
"Updates performance metrics for a skill. STATUS is :success or :rejected."
|
||||
(when skill-name
|
||||
(bordeaux-threads:with-lock-held (*telemetry-lock*)
|
||||
(let ((entry (or (gethash skill-name *telemetry-table*) (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 *telemetry-table*) entry)))))
|
||||
|
||||
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct cognitive-tool
|
||||
name
|
||||
description
|
||||
parameters
|
||||
guard
|
||||
body)
|
||||
|
||||
(defmacro def-cognitive-tool (name description parameters &key guard body)
|
||||
"Registers a cognitive tool. PARAMETERS is a list of plists, one per parameter."
|
||||
`(setf (gethash (string-downcase (string ',name)) *cognitive-tool-registry*)
|
||||
(make-cognitive-tool :name (string-downcase (string ',name))
|
||||
:description ,description
|
||||
:parameters ',parameters
|
||||
:guard ,guard
|
||||
:body ,body)))
|
||||
|
||||
(defun cognitive-tool-prompt ()
|
||||
"Serialises all registered tools into a prompt string for the LLM."
|
||||
(let ((descriptions nil))
|
||||
(maphash (lambda (k tool)
|
||||
(declare (ignore k))
|
||||
(push (format nil "- ~a: ~a~% Parameters: ~a~%"
|
||||
(cognitive-tool-name tool)
|
||||
(cognitive-tool-description tool)
|
||||
(cognitive-tool-parameters tool))
|
||||
descriptions))
|
||||
*cognitive-tool-registry*)
|
||||
(if descriptions
|
||||
(format nil "Available tools:~%~a" (apply #'concatenate 'string (sort descriptions #'string<)))
|
||||
"No tools registered.")))
|
||||
|
||||
(defun log-message (msg &rest args)
|
||||
"Centralized, thread-safe logging for the harness."
|
||||
(let ((formatted-msg (apply #'format nil msg args)))
|
||||
(bordeaux-threads:with-lock-held (*log-lock*)
|
||||
(push formatted-msg *log-buffer*)
|
||||
(when (> (length *log-buffer*) *log-limit*)
|
||||
(setq *log-buffer* (subseq *log-buffer* 0 *log-limit*))))
|
||||
(format t "~a~%" formatted-msg)
|
||||
(finish-output)))
|
||||
|
||||
(setf *debugger-hook* (lambda (condition hook)
|
||||
"Friendly error handler - shows diagnostic message instead of raw debugger."
|
||||
(declare (ignore hook))
|
||||
(format t "~%")
|
||||
(format t "┌─────────────────────────────────────────────┐~%")
|
||||
(format t "│ ERROR: ~A~%" (type-of condition))
|
||||
(format t "│~%")
|
||||
(format t "│ Run: passepartout doctor~%")
|
||||
(format t "│ For system diagnostics~%")
|
||||
(format t "└─────────────────────────────────────────────┘~%")
|
||||
(format t "~%")
|
||||
(format t "Details: ~A~%" condition)
|
||||
(finish-output)
|
||||
(uiop:quit 1)))
|
||||
152
lisp/core-loop-act.lisp
Normal file
152
lisp/core-loop-act.lisp
Normal file
@@ -0,0 +1,152 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *actuator-default* :cli
|
||||
"The actuator used when no explicit target is specified.")
|
||||
|
||||
(defvar *actuator-silent* '(:cli :system-message :emacs)
|
||||
"List of actuators that don't generate tool-output feedback.")
|
||||
|
||||
(defun actuator-initialize ()
|
||||
"Register core actuators and load configuration."
|
||||
(let ((def (uiop:getenv "DEFAULT_ACTUATOR"))
|
||||
(silent (uiop:getenv "SILENT_ACTUATORS")))
|
||||
(when def
|
||||
(setf *actuator-default* (intern (string-upcase def) :keyword)))
|
||||
(when silent
|
||||
(setf *actuator-silent*
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword))
|
||||
(uiop:split-string silent :separator '(#\,))))))
|
||||
|
||||
(register-actuator :system #'action-system-execute)
|
||||
(register-actuator :tool #'action-tool-execute)
|
||||
|
||||
(register-actuator :tui (lambda (action context)
|
||||
(declare (ignore context))
|
||||
(let* ((meta (getf action :meta))
|
||||
(stream (getf meta :reply-stream)))
|
||||
(when (and stream (open-stream-p stream))
|
||||
(format stream "~a" (frame-message action))
|
||||
(finish-output stream))))))
|
||||
|
||||
(defun action-dispatch (action context)
|
||||
"Route an approved action to its registered actuator."
|
||||
(let ((payload (proto-get action :payload)))
|
||||
(when (eq (proto-get payload :sensor) :heartbeat)
|
||||
(return-from action-dispatch nil))
|
||||
|
||||
(when (and action (listp action))
|
||||
(let* ((meta (proto-get context :meta))
|
||||
(source (proto-get meta :source))
|
||||
(raw-target (or (proto-get action :target) source *actuator-default*))
|
||||
(target (intern (string-upcase (string raw-target)) :keyword))
|
||||
(actuator-fn (gethash target *actuator-registry*)))
|
||||
(when (and meta (null (getf action :meta)))
|
||||
(setf (getf action :meta) meta))
|
||||
(if actuator-fn
|
||||
(funcall actuator-fn action context)
|
||||
(log-message "ACT ERROR: No actuator registered for '~s'" target))))))
|
||||
|
||||
(defun action-system-execute (action context)
|
||||
"Execute internal harness commands."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(cmd (getf payload :action)))
|
||||
(case cmd
|
||||
(:eval
|
||||
(eval (read-from-string (getf payload :code))))
|
||||
(:message
|
||||
(log-message "ACT [System]: ~a" (getf payload :text)))
|
||||
(t
|
||||
(log-message "ACT ERROR [System]: Unknown command '~s'" cmd)))))
|
||||
|
||||
(defun action-tool-execute (action context)
|
||||
"Execute a registered cognitive tool."
|
||||
(let* ((payload (getf action :payload))
|
||||
(tool-name (getf payload :tool))
|
||||
(tool-args (getf payload :args))
|
||||
(depth (getf context :depth 0))
|
||||
(meta (getf context :meta))
|
||||
(source (getf meta :source))
|
||||
(tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
||||
(if tool
|
||||
(handler-case
|
||||
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
||||
(result (funcall (cognitive-tool-body tool) clean-args)))
|
||||
(when source
|
||||
(action-dispatch (list :TYPE :REQUEST :TARGET source
|
||||
:PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name result)))
|
||||
context))
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-output :RESULT result :TOOL tool-name)))
|
||||
(error (c)
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c)))))
|
||||
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
||||
:PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name))))))
|
||||
|
||||
(defun tool-result-format (tool-name result)
|
||||
"Format a tool result for display."
|
||||
(if (listp result)
|
||||
(let ((status (getf result :status))
|
||||
(content (getf result :content))
|
||||
(msg (getf result :message)))
|
||||
(cond
|
||||
((and (eq status :success) content) (format nil "~a" content))
|
||||
((and (eq status :error) msg) (format nil "ERROR [~a]: ~a" tool-name msg))
|
||||
(t (format nil "TOOL [~a] RESULT: ~s" tool-name result))))
|
||||
(format nil "TOOL [~a] RESULT: ~a" tool-name result)))
|
||||
|
||||
(defun loop-gate-act (signal)
|
||||
"Final stage of the metabolic pipeline: Actuation."
|
||||
(let* ((approved (getf signal :approved-action))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(source (getf meta :source))
|
||||
(feedback nil))
|
||||
(when approved
|
||||
(let* ((original-type (getf approved :type))
|
||||
(verified (deterministic-verify approved signal)))
|
||||
(if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) (not (member original-type '(:LOG :EVENT))))
|
||||
(progn
|
||||
(log-message "ACT BLOCKED: Action failed last-mile deterministic check.")
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf feedback verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf approved verified)))))
|
||||
|
||||
(case type
|
||||
(:REQUEST (action-dispatch signal signal))
|
||||
(:LOG (action-dispatch signal signal))
|
||||
(:EVENT
|
||||
(if approved
|
||||
(let* ((target (getf approved :target))
|
||||
(result (action-dispatch approved signal)))
|
||||
(cond
|
||||
((and (listp result) (member (getf result :type) '(:EVENT :LOG)))
|
||||
(setf feedback result))
|
||||
((and result (not (member target *actuator-silent*)))
|
||||
(setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta
|
||||
:payload (list :sensor :tool-output :result result :tool approved))))))
|
||||
(when source (action-dispatch signal signal)))))
|
||||
(setf (getf signal :status) :acted)
|
||||
feedback))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-act-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-act-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-act-tests)
|
||||
|
||||
(def-suite pipeline-act-suite :description "Test suite for Act pipeline")
|
||||
(in-suite pipeline-act-suite)
|
||||
|
||||
(test test-loop-gate-act-basic
|
||||
(clrhash passepartout::*skills-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello"))))
|
||||
(result (loop-gate-act signal)))
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null result))))
|
||||
96
lisp/core-loop-perceive.lisp
Normal file
96
lisp/core-loop-perceive.lisp
Normal file
@@ -0,0 +1,96 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *loop-interrupt* nil)
|
||||
|
||||
(defvar *loop-async-sensors* '(:chat-message :delegation :user-command)
|
||||
"Sensors that are processed in dedicated threads.")
|
||||
|
||||
(defvar *loop-focus-id* nil
|
||||
"The Org ID of the node the user is currently interacting with.")
|
||||
|
||||
(defun stimulus-inject (raw-message &key stream (depth 0))
|
||||
"Inject a raw message into the signal processing pipeline."
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
(sensor (getf payload :sensor))
|
||||
(meta (getf raw-message :meta))
|
||||
(async-p (or (getf payload :async-p)
|
||||
(member sensor *loop-async-sensors*))))
|
||||
|
||||
(unless meta
|
||||
(setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal")))
|
||||
|
||||
(when stream
|
||||
(setf (getf meta :reply-stream) stream))
|
||||
|
||||
(setf (getf raw-message :meta) meta)
|
||||
(setf (getf raw-message :depth) depth)
|
||||
|
||||
(if async-p
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(restart-case (process-signal raw-message)
|
||||
(skip-event () nil)))
|
||||
:name "passepartout-async-task")
|
||||
|
||||
(restart-case
|
||||
(handler-bind ((error (lambda (c)
|
||||
(log-message "SYSTEM ERROR: ~a" c)
|
||||
(invoke-restart 'skip-event))))
|
||||
(process-signal raw-message))
|
||||
(skip-event ()
|
||||
(log-message "SYSTEM RECOVERY: Stimulus dropped."))))))
|
||||
|
||||
(defun loop-gate-perceive (signal)
|
||||
"Stage 1 of the metabolic pipeline: Normalize sensory input."
|
||||
(let* ((payload (getf signal :payload))
|
||||
(type (getf signal :type))
|
||||
(meta (getf signal :meta))
|
||||
(sensor (getf payload :sensor)))
|
||||
|
||||
(log-message "GATE [Perceive]: ~a (~a) [Source: ~s]"
|
||||
type (or sensor "no-sensor") (getf meta :source))
|
||||
|
||||
(cond ((eq type :EVENT)
|
||||
(case sensor
|
||||
(:buffer-update
|
||||
(let ((ast (getf payload :ast)))
|
||||
(when ast
|
||||
(snapshot-memory)
|
||||
(ingest-ast ast))))
|
||||
(:point-update
|
||||
(let ((element (getf payload :element)))
|
||||
(when element
|
||||
(snapshot-memory)
|
||||
(setf *loop-focus-id* (getf element :id))
|
||||
(ingest-ast element))))
|
||||
(:interrupt
|
||||
(setf *loop-interrupt* t))))
|
||||
((eq type :RESPONSE)
|
||||
(log-message "GATE [Perceive]: Act Result -> ~a" (getf payload :status))))
|
||||
|
||||
(setf (getf signal :status) :perceived)
|
||||
(setf (getf signal :foveal-focus) *loop-focus-id*)
|
||||
signal))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-perceive-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-perceive-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-perceive-tests)
|
||||
|
||||
(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline")
|
||||
(in-suite pipeline-perceive-suite)
|
||||
|
||||
(test test-loop-gate-perceive
|
||||
(clrhash passepartout::*memory*)
|
||||
(let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil))))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))
|
||||
(is (not (null (gethash "test-node" passepartout::*memory*))))))
|
||||
|
||||
(test test-depth-limiting
|
||||
(let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat))))
|
||||
(is (null (process-signal runaway-signal)))))
|
||||
170
lisp/core-loop-reason.lisp
Normal file
170
lisp/core-loop-reason.lisp
Normal file
@@ -0,0 +1,170 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *backend-registry* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *provider-cascade* nil)
|
||||
|
||||
(defvar *model-selector* nil)
|
||||
|
||||
(defvar *consensus-enabled* nil)
|
||||
|
||||
(defun backend-register (name fn)
|
||||
(setf (gethash name *backend-registry*) fn))
|
||||
|
||||
(defun backend-cascade-call (prompt &key
|
||||
(system-prompt "You are the Probabilistic engine.")
|
||||
(cascade nil)
|
||||
(context nil))
|
||||
(let ((backends (or cascade *provider-cascade*)))
|
||||
(or (dolist (backend backends)
|
||||
(let ((backend-fn (gethash backend *backend-registry*)))
|
||||
(when backend-fn
|
||||
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model (when *model-selector*
|
||||
(funcall *model-selector* backend context)))
|
||||
(result (if model
|
||||
(funcall backend-fn prompt system-prompt :model model)
|
||||
(funcall backend-fn prompt system-prompt))))
|
||||
(cond ((and (listp result) (eq (getf result :status) :success))
|
||||
(return (getf result :content)))
|
||||
((stringp result)
|
||||
(return result))
|
||||
(t
|
||||
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
|
||||
backend (getf result :message))))))))
|
||||
(list :type :LOG
|
||||
:payload (list :text "Neural Cascade Failure: All providers exhausted.")))))
|
||||
|
||||
(defun markdown-strip (text)
|
||||
(if (and text (stringp text))
|
||||
(let ((cleaned text))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
|
||||
(setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
|
||||
(string-trim '(#\Space #\Newline #\Tab) cleaned))
|
||||
text))
|
||||
|
||||
(defun plist-keywords-normalize (plist)
|
||||
(when (listp plist)
|
||||
(loop for (k v) on plist by #'cddr
|
||||
collect (if (and (symbolp k) (not (keywordp k)))
|
||||
(intern (string k) :keyword)
|
||||
k)
|
||||
collect v)))
|
||||
|
||||
(defun think (context)
|
||||
(let* ((active-skill (find-triggered-skill context))
|
||||
(tool-belt (generate-tool-belt-prompt))
|
||||
(global-context (context-assemble-global-awareness))
|
||||
(system-logs (context-get-system-logs))
|
||||
(assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent"))
|
||||
(rejection-trace (proto-get (proto-get context :payload) :rejection-trace))
|
||||
(prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
|
||||
(raw-prompt (if prompt-generator
|
||||
(funcall prompt-generator context)
|
||||
(let ((p (proto-get (proto-get context :payload) :text)))
|
||||
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
|
||||
(reflection-feedback (if rejection-trace
|
||||
(format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
|
||||
""))
|
||||
(skill-augments (let ((augments ""))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(let ((aug-fn (skill-system-prompt-augment skill)))
|
||||
(when aug-fn
|
||||
(let ((aug-text (ignore-errors (funcall aug-fn context))))
|
||||
(when (and aug-text (stringp aug-text) (> (length aug-text) 0))
|
||||
(setf augments (concatenate 'string augments aug-text (string #\Newline))))))))
|
||||
*skills-registry*)
|
||||
(when (> (length augments) 0) augments)))
|
||||
(system-prompt (format nil "IDENTITY: ~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a~%~a"
|
||||
assistant-name reflection-feedback tool-belt global-context system-logs
|
||||
(or skill-augments ""))))
|
||||
(let* ((thought (backend-cascade-call raw-prompt :system-prompt system-prompt :context context))
|
||||
(cleaned (markdown-strip thought)))
|
||||
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
|
||||
(handler-case
|
||||
(let ((parsed (read-from-string cleaned)))
|
||||
(if (listp parsed)
|
||||
(plist-keywords-normalize parsed)
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(error () (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
|
||||
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (if (stringp cleaned) cleaned "No response") :EXPLANATION "Generated by the Probabilistic engine."))))))
|
||||
|
||||
(defun cognitive-verify (proposed-action context)
|
||||
(let ((current-action proposed-action)
|
||||
(skills nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (skill-deterministic-fn skill)
|
||||
(push skill skills)))
|
||||
*skills-registry*)
|
||||
(setf skills (sort skills #'> :key #'skill-priority))
|
||||
(dolist (skill skills)
|
||||
(let ((trigger (skill-trigger-fn skill))
|
||||
(gate (skill-deterministic-fn skill)))
|
||||
(when (or (null trigger) (ignore-errors (funcall trigger context)))
|
||||
(let ((next-action (funcall gate current-action context)))
|
||||
(when (and (listp next-action)
|
||||
(member (proto-get next-action :type) '(:LOG :EVENT)))
|
||||
(log-message "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill))
|
||||
(return-from cognitive-verify next-action))
|
||||
(when next-action (setf current-action next-action))))))
|
||||
current-action))
|
||||
|
||||
(defun loop-gate-reason (signal)
|
||||
(let* ((type (proto-get signal :type))
|
||||
(payload (proto-get signal :payload))
|
||||
(sensor (proto-get payload :sensor)))
|
||||
(unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message)))
|
||||
(return-from loop-gate-reason signal))
|
||||
(let ((retries 3)
|
||||
(current-signal (copy-tree signal))
|
||||
(last-rejection nil))
|
||||
(loop
|
||||
(when (<= retries 0)
|
||||
(setf (getf signal :approved-action) last-rejection)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))
|
||||
(when last-rejection
|
||||
(setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
|
||||
(let ((candidate (think current-signal)))
|
||||
(if (and candidate (listp candidate))
|
||||
(let ((verified (cognitive-verify candidate current-signal)))
|
||||
(if (member (getf verified :type) '(:LOG :EVENT))
|
||||
(progn (decf retries) (setf last-rejection verified))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) verified)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))))
|
||||
(progn
|
||||
(setf (getf signal :approved-action) nil)
|
||||
(setf (getf signal :status) :reasoned)
|
||||
(return signal))))))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-reason-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-reason-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-reason-tests)
|
||||
|
||||
(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline")
|
||||
(in-suite pipeline-reason-suite)
|
||||
|
||||
(test test-decide-gate-safety
|
||||
(clrhash passepartout::*skills-registry*)
|
||||
(passepartout::defskill :mock-safety
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(if (search "rm -rf" (format nil "~s" action))
|
||||
(list :type :LOG :payload (list :text "Rejected"))
|
||||
action)))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
160
lisp/core-loop.lisp
Normal file
160
lisp/core-loop.lisp
Normal file
@@ -0,0 +1,160 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *interrupt-flag* nil
|
||||
"Atomic flag set by signal handlers to trigger graceful shutdown.")
|
||||
|
||||
(defvar *loop-interrupt-lock* (bt:make-lock "harness-interrupt-lock")
|
||||
"Mutex protecting *interrupt-flag* access.")
|
||||
|
||||
(defvar *heartbeat-thread* nil
|
||||
"Handle to the heartbeat thread.")
|
||||
|
||||
(defun loop-process (signal)
|
||||
"The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act."
|
||||
(let ((current-signal signal))
|
||||
(loop while current-signal do
|
||||
(let ((depth (getf current-signal :depth 0))
|
||||
(meta (getf current-signal :meta)))
|
||||
(when (> depth 10)
|
||||
(log-message "METABOLISM ERROR: Max recursion depth reached.")
|
||||
(return nil))
|
||||
|
||||
(when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*)
|
||||
(log-message "METABOLISM: Interrupted by shutdown signal.")
|
||||
(return nil))
|
||||
|
||||
(handler-case
|
||||
(progn
|
||||
(setf current-signal (perceive-gate current-signal))
|
||||
(setf current-signal (reason-gate current-signal))
|
||||
(let ((feedback (act-gate current-signal)))
|
||||
(if feedback
|
||||
(progn
|
||||
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
|
||||
(setf current-signal feedback))
|
||||
(setf current-signal nil))))
|
||||
(error (c)
|
||||
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
|
||||
(log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
|
||||
(unless (member sensor '(:loop-error :tool-error :syntax-error))
|
||||
(log-message "CRITICAL ERROR: Initiating Micro-Rollback.")
|
||||
(rollback-memory 0))
|
||||
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
|
||||
(setf current-signal nil)
|
||||
(setf current-signal
|
||||
(list :type :EVENT :depth (1+ depth) :meta meta
|
||||
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))))))
|
||||
|
||||
(defvar *memory-auto-save-interval* 300)
|
||||
(defvar *heartbeat-save-counter* 0)
|
||||
|
||||
(defun heartbeat-start ()
|
||||
"Starts the background heartbeat thread."
|
||||
(let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60))
|
||||
(auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) *memory-auto-save-interval*)))
|
||||
(setf *memory-auto-save-interval* auto-save)
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
|
||||
(setf *heartbeat-thread*
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(sleep interval)
|
||||
(incf *heartbeat-save-counter*)
|
||||
(when (>= *heartbeat-save-counter* (/ *memory-auto-save-interval* interval))
|
||||
(setf *heartbeat-save-counter* 0)
|
||||
(save-memory-to-disk))
|
||||
(inject-stimulus
|
||||
(list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
|
||||
:name "passepartout-heartbeat"))))
|
||||
|
||||
(defvar *shutdown-save-enabled* t)
|
||||
|
||||
(defvar *system-health* :unknown
|
||||
"Current system health status: :healthy, :degraded, :unhealthy, or :unknown.")
|
||||
|
||||
(defvar *health-check-ran* nil
|
||||
"Flag indicating if initial health check has completed.")
|
||||
|
||||
(defun diagnostics-startup-run ()
|
||||
"Runs the doctor diagnostics on startup. Returns health status."
|
||||
(format t "~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " DOCTOR: Running Startup Health Check~%")
|
||||
(format t "==================================================~%")
|
||||
(handler-case
|
||||
(progn
|
||||
(when (fboundp 'doctor-run-all)
|
||||
(let ((result (doctor-run-all :auto-install nil)))
|
||||
(setf *health-check-ran* t)
|
||||
(if result
|
||||
(progn
|
||||
(setf *system-health* :healthy)
|
||||
(format t "DAEMON: Health check passed. Starting services.~%"))
|
||||
(progn
|
||||
(setf *system-health* :degraded)
|
||||
(format t "DAEMON: Health check found issues.~%")
|
||||
(format t " Run 'passepartout doctor --fix' to repair.~%")))))
|
||||
(setf *health-check-ran* t))
|
||||
(error (c)
|
||||
(format t "DOCTOR ERROR: ~a~%" c)
|
||||
(setf *system-health* :unhealthy)
|
||||
(setf *health-check-ran* t)))
|
||||
(format t "==================================================~%~%"))
|
||||
|
||||
(defun main ()
|
||||
"Entry point for Passepartout. Initializes the system and enters idle loop."
|
||||
(let* ((home (uiop:getenv "HOME"))
|
||||
(env-file (uiop:merge-pathnames* ".config/passepartout/.env" (uiop:ensure-directory-pathname home))))
|
||||
(when (uiop:file-exists-p env-file)
|
||||
(cl-dotenv:load-env env-file)))
|
||||
|
||||
(load-memory-from-disk)
|
||||
(initialize-actuators)
|
||||
(initialize-all-skills)
|
||||
|
||||
;; Run proactive doctor before starting services
|
||||
(diagnostics-startup-run)
|
||||
|
||||
(heartbeat-start)
|
||||
(start-daemon)
|
||||
|
||||
#+sbcl
|
||||
(sb-sys:enable-interrupt sb-unix:sigint
|
||||
(lambda (sig code scp)
|
||||
(declare (ignore sig code scp))
|
||||
(log-message "SHUTDOWN: SIGINT received. Saving memory...")
|
||||
(when *shutdown-save-enabled* (save-memory-to-disk))
|
||||
(uiop:quit 0)))
|
||||
|
||||
(let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600)))
|
||||
(loop
|
||||
(when (bt:with-lock-held (*loop-interrupt-lock*) *interrupt-flag*)
|
||||
(log-message "SHUTDOWN: Interrupt flag set. Saving memory...")
|
||||
(when *shutdown-save-enabled* (save-memory-to-disk))
|
||||
(return))
|
||||
(sleep sleep-interval))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-immune-system-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:immune-suite))
|
||||
|
||||
(in-package :passepartout-immune-system-tests)
|
||||
|
||||
(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)")
|
||||
(in-suite immune-suite)
|
||||
|
||||
(test loop-error-injection
|
||||
"Verify that a crash in think/decide triggers a :loop-error stimulus."
|
||||
(clrhash passepartout::*skills-registry*)
|
||||
(passepartout:defskill :evil-skill
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input))
|
||||
:probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE"))
|
||||
:deterministic nil)
|
||||
(passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(let ((logs (passepartout:context-get-system-logs 20)))
|
||||
(is (not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs))))))
|
||||
164
lisp/core-memory.lisp
Normal file
164
lisp/core-memory.lisp
Normal file
@@ -0,0 +1,164 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *memory-store* (make-hash-table :test 'equal))
|
||||
(defvar *memory-history* (make-hash-table :test 'equal)
|
||||
"Immutable Merkle-Tree versioning store mapping hashes to objects.")
|
||||
|
||||
(defun memory-object-get (id)
|
||||
"Retrieves an memory-object by ID from *memory-store*."
|
||||
(gethash id *memory-store*))
|
||||
|
||||
(defun memory-objects-by-attribute (attr value)
|
||||
"Returns all memory-objects whose :ATTRIBUTES plist has ATTR = VALUE."
|
||||
(let ((results nil))
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore id))
|
||||
(when (equal (getf (memory-object-attributes obj) attr) value)
|
||||
(push obj results)))
|
||||
*memory-store*)
|
||||
(nreverse results)))
|
||||
|
||||
(defun memory-id-generate ()
|
||||
"Generates a UUIDv4 unique ID. Compatible with Agora Note UUIDs."
|
||||
(concatenate 'string "id-" (string-downcase (format nil "~a" (uuid:make-v4-uuid)))))
|
||||
|
||||
(defstruct memory-object
|
||||
id type attributes content vector parent-id children version last-sync hash)
|
||||
|
||||
(defmethod make-load-form ((obj memory-object) &optional env)
|
||||
(make-load-form-saving-slots obj :environment env))
|
||||
|
||||
(defun deep-copy-memory-object (obj)
|
||||
"Creates a full copy of an memory-object, including fresh lists for attributes and children."
|
||||
(make-memory-object :id (memory-object-id obj)
|
||||
:type (memory-object-type obj)
|
||||
:attributes (copy-list (memory-object-attributes obj))
|
||||
:content (memory-object-content obj)
|
||||
:vector (memory-object-vector obj)
|
||||
:parent-id (memory-object-parent-id obj)
|
||||
:children (copy-list (memory-object-children obj))
|
||||
:version (memory-object-version obj)
|
||||
:last-sync (memory-object-last-sync obj)
|
||||
:hash (memory-object-hash obj)))
|
||||
|
||||
(defun memory-merkle-hash (id type attributes content child-hashes)
|
||||
(let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v)))
|
||||
(sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x)))))
|
||||
(attr-string (format nil "~s" sorted-alist))
|
||||
(children-string (format nil "~{~a~}" child-hashes))
|
||||
(data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a"
|
||||
id type attr-string (or content "") children-string))
|
||||
(digester (ironclad:make-digest :sha256)))
|
||||
(ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string))
|
||||
(ironclad:byte-array-to-hex-string (ironclad:produce-digest digester))))
|
||||
|
||||
(defun ingest-ast (ast &optional parent-id)
|
||||
(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 (getf ast :raw-content) ""))))
|
||||
(child-ids nil) (child-hashes nil))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(let ((child-id (ingest-ast child id)))
|
||||
(push child-id child-ids)
|
||||
(let ((child-obj (gethash child-id *memory-store*)))
|
||||
(when child-obj (push (memory-object-hash child-obj) child-hashes))))))
|
||||
(setf child-ids (nreverse child-ids))
|
||||
(setf child-hashes (nreverse child-hashes))
|
||||
(let* ((hash (memory-merkle-hash id type props raw-content child-hashes))
|
||||
(existing-obj (gethash hash *memory-history*))
|
||||
(obj (or existing-obj
|
||||
(make-memory-object
|
||||
:id id :type type :attributes props :content raw-content
|
||||
:parent-id parent-id :children child-ids
|
||||
:version (get-universal-time) :last-sync (get-universal-time)
|
||||
:hash hash))))
|
||||
(unless existing-obj (setf (gethash hash *memory-history*) obj))
|
||||
(setf (gethash id *memory-store*) obj)
|
||||
id)))
|
||||
|
||||
(defvar *memory-snapshots* nil)
|
||||
|
||||
(defun memory-hash-table-copy (hash-table)
|
||||
"Creates an independent copy of a hash table."
|
||||
(let ((new-table (make-hash-table :test (hash-table-test hash-table)
|
||||
:size (hash-table-size hash-table))))
|
||||
(maphash (lambda (k v) (setf (gethash k new-table) v)) hash-table)
|
||||
new-table))
|
||||
|
||||
(defun snapshot-memory ()
|
||||
"Creates a CoW snapshot of *memory-store* for rollback recovery."
|
||||
(let ((snapshot (make-hash-table :test 'equal :size (hash-table-size *memory-store*))))
|
||||
(maphash (lambda (k v) (setf (gethash k snapshot) (deep-copy-memory-object v))) *memory-store*)
|
||||
(push (list :timestamp (get-universal-time) :data snapshot) *memory-snapshots*)
|
||||
(when (> (length *memory-snapshots*) 20)
|
||||
(setf *memory-snapshots* (subseq *memory-snapshots* 0 20)))
|
||||
(log-message "MEMORY - CoW Memory snapshot created.")))
|
||||
|
||||
(defun rollback-memory (&optional (index 0))
|
||||
"Restores *memory-store* from a snapshot. INDEX 0 = most recent."
|
||||
(let ((snapshot (nth index *memory-snapshots*)))
|
||||
(if snapshot
|
||||
(progn (setf *memory-store* (memory-hash-table-copy (getf snapshot :data)))
|
||||
(log-message "MEMORY - Memory rolled back to snapshot ~a" index))
|
||||
(log-message "MEMORY ERROR - Snapshot ~a not found." index))))
|
||||
|
||||
(defvar *memory-snapshot-path* nil)
|
||||
|
||||
(defun memory-snapshot-path-ensure ()
|
||||
"Returns the path to the memory snapshot file, resolving env or default."
|
||||
(or *memory-snapshot-path*
|
||||
(let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH")))
|
||||
(setf *memory-snapshot-path*
|
||||
(or env-path (namestring (uiop:merge-pathnames* "memory.snap" (user-homedir-pathname))))))))
|
||||
|
||||
(defun save-memory-to-disk ()
|
||||
"Writes the entire memory and history store to disk as a plist."
|
||||
(let ((path (memory-snapshot-path-ensure)))
|
||||
(with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(let ((memory-alist nil) (history-alist nil))
|
||||
(maphash (lambda (k v) (push (cons k v) memory-alist)) *memory-store*)
|
||||
(maphash (lambda (k v) (push (cons k v) history-alist)) *memory-history*)
|
||||
(prin1 (list :memory memory-alist :history-store history-alist) stream)))
|
||||
(log-message "MEMORY - Saved to ~a" path)))
|
||||
|
||||
(defun load-memory-from-disk ()
|
||||
"Reads memory state from disk and restores *memory-store* and *memory-history*."
|
||||
(let ((path (memory-snapshot-path-ensure)))
|
||||
(when (uiop:file-exists-p path)
|
||||
(handler-case
|
||||
(with-open-file (stream path :direction :input)
|
||||
(let ((data (read stream nil)))
|
||||
(when data
|
||||
(let ((memory-alist (getf data :memory)) (history-alist (getf data :history-store)))
|
||||
(setf *memory-store* (make-hash-table :test 'equal :size (length memory-alist)))
|
||||
(dolist (kv memory-alist) (setf (gethash (car kv) *memory-store*) (cdr kv)))
|
||||
(setf *memory-history* (make-hash-table :test 'equal :size (length history-alist)))
|
||||
(dolist (kv history-alist) (setf (gethash (car kv) *memory-history*) (cdr kv)))
|
||||
(log-message "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory-store*))))))
|
||||
(error (c) (log-message "MEMORY WARNING - Failed to load snapshot: ~a" c)))))
|
||||
t)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-memory-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:memory-suite))
|
||||
|
||||
(in-package :passepartout-memory-tests)
|
||||
|
||||
(def-suite memory-suite :description "Tests for the Merkle-Tree Memory")
|
||||
(in-suite memory-suite)
|
||||
|
||||
(test merkle-hash-consistency
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id1 (ingest-ast ast1)))
|
||||
(let ((hash1 (memory-object-hash (memory-object-get id1))))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id2 (ingest-ast ast1)))
|
||||
(is (equal hash1 (memory-object-hash (memory-object-get id2)))))))))
|
||||
284
lisp/core-skills.lisp
Normal file
284
lisp/core-skills.lisp
Normal file
@@ -0,0 +1,284 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun vector-cosine-similarity (v1 v2)
|
||||
"Computes cosine similarity between two vectors."
|
||||
(let* ((len1 (length v1)) (len2 (length v2)))
|
||||
(if (or (zerop len1) (zerop len2))
|
||||
0.0
|
||||
(let* ((dot 0.0d0) (n1 0.0d0) (n2 0.0d0))
|
||||
(dotimes (i (min len1 len2))
|
||||
(let* ((x (coerce (elt v1 i) 'double-float)) (y (coerce (elt v2 i) 'double-float)))
|
||||
(incf dot (* x y)) (incf n1 (* x x)) (incf n2 (* y y))))
|
||||
(if (or (zerop n1) (zerop n2)) 0.0 (/ dot (sqrt (* n1 n2))))))))
|
||||
|
||||
(defun VAULT-MASK-STRING (s) (declare (ignore s)) "[MASKED]")
|
||||
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn system-prompt-augment)
|
||||
|
||||
(defvar *skill-registry* (make-hash-table :test 'equal))
|
||||
|
||||
(defvar *skill-catalog* (make-hash-table :test 'equal)
|
||||
"Tracks all discovered skill files and their loading state.")
|
||||
|
||||
(defstruct skill-entry filename (status :discovered) error-log (load-time 0))
|
||||
|
||||
(defun skill-triggered-find (context)
|
||||
"Returns the highest priority skill whose trigger matches context."
|
||||
(let ((triggered nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(when (and (skill-probabilistic-prompt skill)
|
||||
(ignore-errors (funcall (skill-trigger-fn skill) context)))
|
||||
(push skill triggered)))
|
||||
*skill-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
|
||||
(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic system-prompt-augment)
|
||||
"Registers a new skill. NAME is a keyword. TRIGGER is a function (context) → bool."
|
||||
`(setf (gethash (string-downcase (string ,name)) *skill-registry*)
|
||||
(make-skill :name (string-downcase (string ,name))
|
||||
:priority (or ,priority 10)
|
||||
:dependencies ',dependencies
|
||||
:trigger-fn ,trigger
|
||||
:probabilistic-prompt ,probabilistic
|
||||
:deterministic-fn ,deterministic
|
||||
:system-prompt-augment ,system-prompt-augment)))
|
||||
|
||||
(defun skill-dependencies-resolve (skill-name)
|
||||
"Resolves transitive dependencies. Returns list of skill names in dependency 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)) *skill-registry*)))
|
||||
(when skill
|
||||
(dolist (dep (skill-dependencies skill)) (visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name)
|
||||
(nreverse resolved))))
|
||||
|
||||
(defun skill-metadata-parse (filepath)
|
||||
"Extracts ID and DEPENDS_ON tags from org file."
|
||||
(let ((dependencies nil) (id nil) (content (uiop:read-file-string filepath)))
|
||||
(let ((id-start (search ":ID:" content)))
|
||||
(when id-start
|
||||
(let ((id-end (position #\Newline content :start id-start)))
|
||||
(when id-end (setf id (string-trim " " (subseq content (+ id-start 4) id-end)))))))
|
||||
(let ((pos 0))
|
||||
(loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos))
|
||||
do (let ((end (position #\Newline content :start pos)))
|
||||
(when end
|
||||
(let ((line (string-trim " " (subseq content (+ pos 13) end))))
|
||||
(dolist (d (uiop:split-string line :separator '(#\Space #\Tab)))
|
||||
(unless (string= d "") (push d dependencies))))
|
||||
(setf pos end)))))
|
||||
(values id (reverse dependencies))))
|
||||
|
||||
(defun skill-topological-sort (skills-dir)
|
||||
"Returns a list of skill filepaths sorted by dependency."
|
||||
(let* ((org-files (uiop:directory-files skills-dir "*.org"))
|
||||
(lisp-files (uiop:directory-files skills-dir "*.lisp"))
|
||||
(all-files (append org-files lisp-files))
|
||||
(files (remove-if (lambda (f)
|
||||
(let ((n (pathname-name f)))
|
||||
(or (string= n "core-defpackage")
|
||||
(string= n "core-skills")
|
||||
(string= n "core-communication")
|
||||
(string= n "core-memory")
|
||||
(string= n "core-context")
|
||||
(string= n "core-loop-perceive")
|
||||
(string= n "core-loop-reason")
|
||||
(string= n "core-loop-act")
|
||||
(string= n "core-loop")
|
||||
(string= n "core-manifest"))))
|
||||
all-files))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
(id-to-file (make-hash-table :test 'equal))
|
||||
(result nil)
|
||||
(visited (make-hash-table :test 'equal))
|
||||
(stack (make-hash-table :test 'equal)))
|
||||
(dolist (file files)
|
||||
(let ((filename (pathname-name file)))
|
||||
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
||||
(progn
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
(unless (gethash (string-downcase filename) adj)
|
||||
(setf (gethash (string-downcase filename) adj) nil)))
|
||||
(multiple-value-bind (id deps) (skill-metadata-parse file)
|
||||
(setf (gethash (string-downcase filename) name-to-file) file)
|
||||
(when id (setf (gethash (string-downcase id) id-to-file) file))
|
||||
(setf (gethash (string-downcase filename) adj) deps)))))
|
||||
(labels ((visit (file)
|
||||
(let* ((filename (pathname-name file))
|
||||
(node-key (string-downcase filename)))
|
||||
(unless (gethash node-key visited)
|
||||
(setf (gethash node-key stack) t)
|
||||
(dolist (dep (gethash node-key adj))
|
||||
(let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep)))
|
||||
(dep-key (string-downcase (if is-id-p (subseq dep 3) dep)))
|
||||
(dep-file (if is-id-p
|
||||
(gethash dep-key id-to-file)
|
||||
(or (gethash dep-key id-to-file)
|
||||
(gethash dep-key name-to-file)))))
|
||||
(when dep-file
|
||||
(let ((dep-filename (pathname-name dep-file)))
|
||||
(if (gethash (string-downcase dep-filename) stack)
|
||||
(error "Circular dependency detected")
|
||||
(visit dep-file))))))
|
||||
(setf (gethash node-key stack) nil)
|
||||
(setf (gethash node-key visited) t)
|
||||
(push file result)))))
|
||||
(let ((filenames (sort (mapcar #'pathname-name files) #'string<)))
|
||||
(dolist (name filenames)
|
||||
(let ((file (gethash (string-downcase name) name-to-file)))
|
||||
(when file (visit file)))))
|
||||
(nreverse result))))
|
||||
|
||||
(defun lisp-syntax-validate (code-string)
|
||||
"Checks if a string contains valid Common Lisp forms."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values t nil))
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
|
||||
(defun skill-package-forms-strip (code-string)
|
||||
"Removes in-package forms so symbols get defined in skill package."
|
||||
(let ((lines (uiop:split-string code-string :separator '(#\Newline)))
|
||||
(result ""))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
||||
(unless (uiop:string-prefix-p "(in-package" trimmed)
|
||||
(setf result (concatenate 'string result line (string #\Newline))))))
|
||||
result))
|
||||
|
||||
(defun tangle-target-extract (line)
|
||||
"Extracts the value of the :tangle header."
|
||||
(let ((pos (search ":tangle" line)))
|
||||
(when pos
|
||||
(let ((rest (string-tirm '(#\Space #\Tab) (subseq line (+ pos 7)))))
|
||||
(let ((end (position #\Space rest)))
|
||||
(if end (subseq rest 0 end) rest))))))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses and evaluates Lisp blocks from an Org file."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil) (collect-this-block nil) (lisp-code "")
|
||||
(pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond
|
||||
((uiop:string-prefix-p "#+begin_src lisp" clean-line)
|
||||
(setf in-lisp-block t)
|
||||
(let ((target (tangle-target-extract clean-line)))
|
||||
(setf collect-this-block (or (null target)
|
||||
(and (not (search "no" target))
|
||||
(not (search "/tests" target)))))))
|
||||
((uiop:string-prefix-p "#+end_src" clean-line)
|
||||
(setf in-lisp-block nil) (setf collect-this-block nil))
|
||||
((and in-lisp-block collect-this-block)
|
||||
(unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":END:" (string-upcase clean-line))
|
||||
(uiop:string-prefix-p ":ID:" (string-upcase clean-line)))
|
||||
(setf lisp-code (concatenate 'string lisp-code line (string #\Newline))))))))
|
||||
(if (= (length lisp-code) 0)
|
||||
(setf (skill-entry-status entry) :ready)
|
||||
(progn
|
||||
(multiple-value-bind (valid-p err) (lisp-syntax-validate lisp-code)
|
||||
(unless valid-p (error err)))
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(log-message "LOADER: Evaluating code for '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
||||
|
||||
(let* ((target-pkg (find-package :passepartout))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(log-message "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (eq (symbol-package sym) (find-package pkg-name))
|
||||
(let ((sn (symbol-name sym)))
|
||||
(when (or (uiop:string-prefix-p raw-name sn)
|
||||
(uiop:string-prefix-p short-name sn)
|
||||
(string-equal sn "DIAGNOSTICS-MAIN")
|
||||
(string-equal sn "DIAGNOSTICS-RUN-ALL")
|
||||
(string-equal sn "SETUP-WIZARD-RUN"))
|
||||
(log-message "LOADER: Exporting ~a to :PASSEPARTOUT" sn)
|
||||
(let ((existing (find-symbol sn target-pkg)))
|
||||
(when (and existing (not (eq existing sym)))
|
||||
(unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg))))))
|
||||
|
||||
(setf (skill-entry-status entry) :ready)))
|
||||
t)
|
||||
(error (c)
|
||||
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
(setf (skill-entry-status entry) :failed) nil))))
|
||||
|
||||
(defun load-skill-from-lisp (filepath)
|
||||
"Loads a .lisp skill file directly, filtering out in-package forms."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(handler-case
|
||||
(let* ((content (skill-package-forms-strip (uiop:read-file-string filepath)))
|
||||
(pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(multiple-value-bind (valid-p err) (lisp-syntax-validate content)
|
||||
(unless valid-p (error err)))
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(log-message "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*))
|
||||
(with-input-from-string (s content)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (handler-case (eval form)
|
||||
(error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c))))))
|
||||
(let* ((target-pkg (find-package :passepartout))
|
||||
(raw-name (string-upcase skill-base-name))
|
||||
(short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name)
|
||||
(subseq raw-name 10)
|
||||
raw-name)))
|
||||
(log-message "LOADER: Scanning package ~a for symbols to export..." (package-name (find-package pkg-name)))
|
||||
(do-symbols (sym (find-package pkg-name))
|
||||
(when (eq (symbol-package sym) (find-package pkg-name))
|
||||
(let ((sn (symbol-name sym)))
|
||||
(when (or (uiop:string-prefix-p raw-name sn)
|
||||
(uiop:string-prefix-p short-name sn)
|
||||
(string-equal sn "DIAGNOSTICS-MAIN")
|
||||
(string-equal sn "DIAGNOSTICS-RUN-ALL")
|
||||
(string-equal sn "SETUP-WIZARD-RUN"))
|
||||
(log-message "LOADER: Exporting ~a to :PASSEPARTOUT" sn)
|
||||
(let ((existing (find-symbol sn target-pkg)))
|
||||
(when (and existing (not (eq existing sym)))
|
||||
(unintern existing target-pkg)))
|
||||
(import sym target-pkg)
|
||||
(export sym target-pkg))))))
|
||||
(setf (skill-entry-status entry) :ready))
|
||||
(error (c)
|
||||
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
||||
(setf (skill-entry-status entry) :failed) nil))))
|
||||
|
||||
(defun skill-initialize-all ()
|
||||
"Initializes all skills from the XDG data directory."
|
||||
(let* ((data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname))))))
|
||||
(skills-dir (merge-pathnames "lisp/" (uiop:ensure-directory-pathname data-dir))))
|
||||
(unless (uiop:directory-exists-p skills-dir) (return-from skill-initialize-all nil))
|
||||
(let ((sorted-files (skill-topological-sort skills-dir)))
|
||||
(log-message "LOADER: Initializing ~a skills..." (length sorted-files))
|
||||
(dolist (file sorted-files)
|
||||
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
||||
(load-skill-from-lisp file)
|
||||
(load-skill-from-org file)))
|
||||
(log-message "LOADER: Boot Complete."))))
|
||||
10
lisp/gateway-cli.lisp
Normal file
10
lisp/gateway-cli.lisp
Normal file
@@ -0,0 +1,10 @@
|
||||
(defun gateway-cli-input (text)
|
||||
"Processes raw text from the command line."
|
||||
(inject-stimulus (list :type :EVENT
|
||||
:payload (list :sensor :user-input :text text)
|
||||
:meta (list :source :CLI))))
|
||||
|
||||
(defskill :passepartout-gateway-cli
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
43
lisp/gateway-llm.lisp
Normal file
43
lisp/gateway-llm.lisp
Normal file
@@ -0,0 +1,43 @@
|
||||
(defun gateway-llm-request (&key prompt system-prompt (provider :ollama) model)
|
||||
"Central dispatcher for LLM requests."
|
||||
(let ((backend (gethash provider *probabilistic-backends*)))
|
||||
(if backend
|
||||
(handler-case
|
||||
(funcall backend prompt system-prompt :model model)
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))
|
||||
(list :status :error :message (format nil "Provider ~a not registered" provider)))))
|
||||
|
||||
(defskill :passepartout-gateway-llm
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (getf ctx :user-input))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-llm-gateway-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:llm-gateway-suite))
|
||||
|
||||
(in-package :passepartout-llm-gateway-tests)
|
||||
|
||||
(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM Gateway skill")
|
||||
(fiveam:in-suite llm-gateway-suite)
|
||||
|
||||
(fiveam:test test-llm-gateway-timeout
|
||||
"Tier 2 Chaos: Verify that LLM Gateway handles connection failures gracefully."
|
||||
(let ((old-host (uiop:getenv "OLLAMA_HOST")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "OLLAMA_HOST") "localhost:1")
|
||||
(let ((fn (or (find-symbol "EXECUTE-LLM-REQUEST" :passepartout.gateway-llm)
|
||||
(find-symbol "EXECUTE-LLM-REQUEST" :passepartout))))
|
||||
(if fn
|
||||
(let ((result (funcall fn :prompt "hello" :provider :ollama)))
|
||||
(fiveam:is (eq (getf result :status) :error))
|
||||
(fiveam:is (uiop:string-prefix-p "Ollama Failure" (getf result :message))))
|
||||
(fiveam:fail "Could not find EXECUTE-LLM-REQUEST symbol"))))
|
||||
(if old-host
|
||||
(setf (uiop:getenv "OLLAMA_HOST") old-host)
|
||||
(sb-posix:unsetenv "OLLAMA_HOST")))))
|
||||
214
lisp/gateway-manager.lisp
Normal file
214
lisp/gateway-manager.lisp
Normal file
@@ -0,0 +1,214 @@
|
||||
(defvar *gateway-configs* (make-hash-table :test 'equal)
|
||||
"Maps platform name → plist (:token :thread :interval :enabled)")
|
||||
|
||||
(defvar *gateway-registry* (make-hash-table :test 'equal)
|
||||
"Maps platform name → plist (:poll-fn :send-fn :default-interval)")
|
||||
|
||||
(defun telegram-get-token ()
|
||||
(vault-get-secret :telegram))
|
||||
|
||||
(defun telegram-poll ()
|
||||
"Polls Telegram for new messages and injects them into the harness."
|
||||
(let* ((token (telegram-get-token)))
|
||||
(when token
|
||||
(let* ((last-id (getf (gethash "telegram" *gateway-configs*) :last-update-id 0))
|
||||
(url (format nil "https://api.telegram.org/bot~a/getUpdates?offset=~a"
|
||||
token (1+ last-id))))
|
||||
(handler-case
|
||||
(let* ((response (dex:get url))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(updates (cdr (assoc :result json))))
|
||||
(dolist (update updates)
|
||||
(let* ((update-id (cdr (assoc :update--id update)))
|
||||
(message (cdr (assoc :message update)))
|
||||
(chat (cdr (assoc :chat message)))
|
||||
(chat-id (cdr (assoc :id chat)))
|
||||
(text (cdr (assoc :text message))))
|
||||
(setf (getf (gethash "telegram" *gateway-configs*) :last-update-id) update-id)
|
||||
(when (and text chat-id)
|
||||
(log-message "TELEGRAM: Received message from ~a" chat-id)
|
||||
(inject-stimulus
|
||||
(list :type :EVENT
|
||||
:meta (list :source :telegram :chat-id (format nil "~a" chat-id))
|
||||
:payload (list :sensor :user-input :text text)))))))
|
||||
(error (c) (log-message "TELEGRAM POLL ERROR: ~a" c))))))
|
||||
|
||||
(defun telegram-send (action context)
|
||||
"Sends a message via Telegram."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(meta (getf action :meta))
|
||||
(chat-id (or (getf meta :chat-id) (getf payload :chat-id) (getf action :chat-id)))
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(token (telegram-get-token)))
|
||||
(when (and token chat-id text)
|
||||
(log-message "TELEGRAM: Sending message to ~a..." chat-id)
|
||||
(handler-case
|
||||
(let ((url (format nil "https://api.telegram.org/bot~a/sendMessage" token)))
|
||||
(dex:post url
|
||||
:headers '(("Content-Type" . "application/json"))
|
||||
:content (cl-json:encode-json-to-string
|
||||
`((chat_id . ,chat-id) (text . ,text)))))
|
||||
(error (c) (log-message "TELEGRAM ERROR: ~a" c))))))
|
||||
|
||||
(defun signal-get-account ()
|
||||
(vault-get-secret :signal))
|
||||
|
||||
(defun signal-poll ()
|
||||
"Polls Signal for new messages and injects them into the harness."
|
||||
(let ((account (signal-get-account)))
|
||||
(when account
|
||||
(handler-case
|
||||
(let* ((output (uiop:run-program (list "signal-cli" "-u" account "receive" "--json")
|
||||
:output :string :error-output :string :ignore-error-status t))
|
||||
(lines (cl-ppcre:split "\\n" output)))
|
||||
(dolist (line lines)
|
||||
(when (and line (> (length line) 0))
|
||||
(let* ((json (ignore-errors (cl-json:decode-json-from-string line)))
|
||||
(envelope (cdr (assoc :envelope json)))
|
||||
(source (cdr (assoc :source envelope)))
|
||||
(data-message (cdr (assoc :data-message envelope)))
|
||||
(text (cdr (assoc :message data-message))))
|
||||
(when (and source text)
|
||||
(log-message "SIGNAL: Received message from ~a" source)
|
||||
(inject-stimulus
|
||||
(list :type :EVENT
|
||||
:meta (list :source :signal :chat-id source)
|
||||
:payload (list :sensor :user-input :text text))))))))
|
||||
(error (c) (log-message "SIGNAL POLL ERROR: ~a" c))))))
|
||||
|
||||
(defun signal-send (action context)
|
||||
"Sends a message via Signal."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(meta (getf action :meta))
|
||||
(chat-id (or (getf meta :chat-id) (getf payload :chat-id) (getf action :chat-id)))
|
||||
(text (or (getf payload :text) (getf action :text)))
|
||||
(account (signal-get-account)))
|
||||
(when (and account chat-id text)
|
||||
(log-message "SIGNAL: Sending message to ~a..." chat-id)
|
||||
(handler-case
|
||||
(uiop:run-program (list "signal-cli" "-u" account "send" "-m" text chat-id)
|
||||
:output :string :error-output :string)
|
||||
(error (c) (log-message "SIGNAL ERROR: ~a" c))))))
|
||||
|
||||
(defun gateway-registry-initialize ()
|
||||
"Registers all built-in gateway handlers."
|
||||
(setf (gethash "telegram" *gateway-registry*)
|
||||
(list :poll-fn #'telegram-poll
|
||||
:send-fn #'telegram-send
|
||||
:default-interval 3))
|
||||
(setf (gethash "signal" *gateway-registry*)
|
||||
(list :poll-fn #'signal-poll
|
||||
:send-fn #'signal-send
|
||||
:default-interval 5)))
|
||||
|
||||
(defun gateway-configured-p (platform)
|
||||
"Returns T if a platform has a stored token."
|
||||
(let ((config (gethash platform *gateway-configs*)))
|
||||
(and config (getf config :token))))
|
||||
|
||||
(defun gateway-active-p (platform)
|
||||
"Returns T if a platform's polling thread is alive."
|
||||
(let ((config (gethash platform *gateway-configs*)))
|
||||
(and config
|
||||
(getf config :thread)
|
||||
(bt:thread-alive-p (getf config :thread)))))
|
||||
|
||||
(defun gateway-link (platform token)
|
||||
"Links a platform with a token and starts polling."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(unless (gethash platform-lc *gateway-registry*)
|
||||
(error "Unknown platform: ~a. Available: ~{~a~^, ~}"
|
||||
platform (loop for k being the hash-keys of *gateway-registry* collect k)))
|
||||
(when (or (null token) (zerop (length token)))
|
||||
(error "Token cannot be empty"))
|
||||
(log-message "GATEWAY: Linking to ~a..." platform-lc)
|
||||
(gateway-unlink platform-lc)
|
||||
(let* ((registry-entry (gethash platform-lc *gateway-registry*))
|
||||
(interval (or (getf registry-entry :default-interval) 5)))
|
||||
(setf (gethash platform-lc *gateway-configs*)
|
||||
(list :token token :interval interval :enabled t))
|
||||
(vault-set-secret (intern (string-upcase platform-lc) :keyword) token)
|
||||
(gateway-start platform-lc)
|
||||
(log-message "GATEWAY: Successfully linked ~a" platform-lc)
|
||||
(format t "Successfully linked ~a gateway. Token stored securely.~%" platform-lc)
|
||||
t)))
|
||||
|
||||
(defun gateway-unlink (platform)
|
||||
"Unlinks a platform and stops its polling thread."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(gateway-stop platform-lc)
|
||||
(remhash platform-lc *gateway-configs*)
|
||||
(log-message "GATEWAY: Unlinked ~a" platform-lc)
|
||||
(format t "Successfully unlinked ~a gateway.~%" platform-lc)
|
||||
t))
|
||||
|
||||
(defun gateway-start (platform)
|
||||
"Starts the polling thread for a linked gateway."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(let ((config (gethash platform-lc *gateway-configs*)))
|
||||
(when (and config (getf config :enabled) (not (gateway-active-p platform-lc)))
|
||||
(let ((poll-fn (getf (gethash platform-lc *gateway-registry*) :poll-fn)))
|
||||
(when poll-fn
|
||||
(let ((interval (getf config :interval)))
|
||||
(setf (getf config :thread)
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(when (getf (gethash platform-lc *gateway-configs*) :enabled)
|
||||
(funcall poll-fn))
|
||||
(sleep interval)))
|
||||
:name (format nil "passepartout-~a-gateway" platform-lc)))
|
||||
(log-message "GATEWAY: Started ~a polling (interval: ~as)" platform-lc interval)))))))))
|
||||
|
||||
(defun gateway-stop (platform)
|
||||
"Stops the polling thread for a gateway."
|
||||
(let ((platform-lc (string-downcase platform)))
|
||||
(let ((config (gethash platform-lc *gateway-configs*)))
|
||||
(when (and config (getf config :thread))
|
||||
(when (bt:thread-alive-p (getf config :thread))
|
||||
(log-message "GATEWAY: Stopping ~a polling thread" platform-lc)
|
||||
(bt:destroy-thread (getf config :thread))))
|
||||
(setf (getf config :thread) nil))))
|
||||
|
||||
(defun gateway-list ()
|
||||
"Returns a list of all gateways with their status."
|
||||
(loop for platform being the hash-keys of *gateway-registry*
|
||||
collect (let ((configured (gateway-configured-p platform))
|
||||
(active (gateway-active-p platform)))
|
||||
(list :platform platform
|
||||
:configured configured
|
||||
:active active))))
|
||||
|
||||
(defun gateway-list-print ()
|
||||
"Prints a formatted table of gateways."
|
||||
(format t "~%")
|
||||
(format t " ~20@A ~12@A ~10@A~%" "PLATFORM" "CONFIGURED" "STATUS")
|
||||
(dolist (gw (gateway-list))
|
||||
(format t " ~20@A ~12@A ~10@A~%"
|
||||
(getf gw :platform)
|
||||
(if (getf gw :configured) "yes" "no")
|
||||
(cond
|
||||
((getf gw :active) "ACTIVE")
|
||||
((getf gw :configured) "stopped")
|
||||
(t "not linked"))))
|
||||
(format t "~%"))
|
||||
|
||||
(defun gateway-start-all ()
|
||||
"Called at boot to start all configured gateways."
|
||||
(dolist (config (loop for platform being the hash-keys of *gateway-configs*
|
||||
collect (list platform (gethash platform *gateway-configs*))))
|
||||
(destructuring-bind (platform config) config
|
||||
(when (and (getf config :enabled) (not (gateway-active-p platform)))
|
||||
(gateway-start platform)))))
|
||||
|
||||
(register-actuator :telegram #'telegram-send)
|
||||
(register-actuator :signal #'signal-send)
|
||||
|
||||
(defskill :passepartout-gateway-manager
|
||||
:priority 150
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(gateway-registry-initialize)
|
||||
(gateway-start-all)
|
||||
81
lisp/gateway-provider.lisp
Normal file
81
lisp/gateway-provider.lisp
Normal file
@@ -0,0 +1,81 @@
|
||||
(defparameter *provider-configs*
|
||||
'((:ollama . (:base-url nil :key-env nil :default-model "llama3"))
|
||||
(:openrouter . (:base-url "https://openrouter.ai/api/v1" :key-env "OPENROUTER_API_KEY" :default-model "openrouter/auto"))
|
||||
(:openai . (:base-url "https://api.openai.com/v1" :key-env "OPENAI_API_KEY" :default-model "gpt-4o-mini"))
|
||||
(:anthropic . (:base-url "https://api.anthropic.com/v1" :key-env "ANTHROPIC_API_KEY" :default-model "claude-3-5-sonnet-20241022"))
|
||||
(:groq . (:base-url "https://api.groq.com/openai/v1" :key-env "GROQ_API_KEY" :default-model "llama-3.1-70b-versatile"))
|
||||
(:gemini . (:base-url "https://generativelanguage.googleapis.com/v1beta/openai" :key-env "GEMINI_API_KEY" :default-model "gemini-2.0-flash"))
|
||||
(:deepseek . (:base-url "https://api.deepseek.com/v1" :key-env "DEEPSEEK_API_KEY" :default-model "deepseek-chat"))
|
||||
(:nvidia . (:base-url "https://integrate.api.nvidia.com/v1" :key-env "NVIDIA_API_KEY" :default-model "meta/llama-3.1-405b-instruct"))))
|
||||
|
||||
(defun provider-config (provider)
|
||||
"Returns the configuration plist for a provider keyword."
|
||||
(cdr (assoc provider *provider-configs*)))
|
||||
|
||||
(defun provider-available-p (provider)
|
||||
"Checks if a provider is configured. Ollama is always considered available."
|
||||
(let* ((config (provider-config provider))
|
||||
(key-env (getf config :key-env))
|
||||
(base-url (getf config :base-url)))
|
||||
(cond ((eq provider :ollama) t)
|
||||
(key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0))))
|
||||
(base-url t))))
|
||||
|
||||
(defun provider-openai-request (prompt system-prompt &key model (provider :ollama))
|
||||
"Executes a request against any OpenAI-compatible API endpoint."
|
||||
(let* ((config (provider-config provider))
|
||||
(base-url (getf config :base-url))
|
||||
(key-env (getf config :key-env))
|
||||
(default-model (getf config :default-model))
|
||||
(api-key (when key-env (uiop:getenv key-env)))
|
||||
(model-id (or model default-model))
|
||||
(url (if (eq provider :ollama)
|
||||
(format nil "http://~a/v1/chat/completions" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||
(format nil "~a/chat/completions" base-url)))
|
||||
(headers `(("Content-Type" . "application/json")
|
||||
,@(when api-key `(("Authorization" . ,(format nil "Bearer ~a" api-key))))
|
||||
,@(when (eq provider :openrouter)
|
||||
`(("HTTP-Referer" . "https://github.com/amrgharbeia/passepartout")
|
||||
("X-Title" . "Passepartout")))))
|
||||
(body (cl-json:encode-json-to-string
|
||||
`((model . ,model-id)
|
||||
(messages . (( (role . "system") (content . ,system-prompt) )
|
||||
( (role . "user") (content . ,prompt) )))))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post url :headers headers :content body :connect-timeout 10 :read-timeout 60))
|
||||
(json (cl-json:decode-json-from-string response))
|
||||
(choices (cdr (assoc :choices json)))
|
||||
(first-choice (car choices))
|
||||
(message (cdr (assoc :message first-choice)))
|
||||
(content (cdr (assoc :content message))))
|
||||
(if content
|
||||
(list :status :success :content content)
|
||||
(list :status :error :message (format nil "~a: No content in response (~s)" provider json))))
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))))
|
||||
|
||||
(defun provider-register-all ()
|
||||
"Scans environment variables and registers all available LLM backends."
|
||||
(dolist (entry *provider-configs*)
|
||||
(let ((provider (car entry)))
|
||||
(when (provider-available-p provider)
|
||||
(log-message "LLM BACKEND: Registering provider ~a" provider)
|
||||
(register-probabilistic-backend provider
|
||||
(lambda (prompt system-prompt &key model)
|
||||
(provider-openai-request prompt system-prompt :model model :provider provider)))))))
|
||||
|
||||
(defun provider-cascade-initialize ()
|
||||
"Reads PROVIDER_CASCADE from env and sets *provider-cascade*."
|
||||
(let ((cascade-str (uiop:getenv "PROVIDER_CASCADE")))
|
||||
(if cascade-str
|
||||
(setf *provider-cascade*
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword))
|
||||
(uiop:split-string cascade-str :separator '(#\,))))
|
||||
(setf *provider-cascade* (mapcar #'car *provider-configs*)))))
|
||||
|
||||
(provider-register-all)
|
||||
(provider-cascade-initialize)
|
||||
|
||||
(defskill :passepartout-gateway-provider
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
155
lisp/gateway-tui.lisp
Normal file
155
lisp/gateway-tui.lisp
Normal file
@@ -0,0 +1,155 @@
|
||||
(in-package :cl-user)
|
||||
(defpackage :passepartout.gateway-tui
|
||||
(:use :cl :croatoan :usocket :bordeaux-threads)
|
||||
(:export :main))
|
||||
(in-package :passepartout.gateway-tui)
|
||||
|
||||
(defvar *daemon-host* "localhost")
|
||||
|
||||
(defvar *daemon-port* 9105)
|
||||
|
||||
(defvar *socket* nil)
|
||||
|
||||
(defvar *stream* nil)
|
||||
|
||||
(defvar *chat-history* nil)
|
||||
|
||||
(defvar *input-buffer* nil)
|
||||
|
||||
(defvar *is-running* t)
|
||||
|
||||
(defvar *queue-lock* (bt:make-lock "incoming-queue-lock"))
|
||||
|
||||
(defvar *incoming* nil)
|
||||
|
||||
(defun log-debug (msg &rest args)
|
||||
(ignore-errors
|
||||
(with-open-file (s "/tmp/passepartout-tui-debug.log" :direction :output :if-exists :append :if-does-not-exist :create)
|
||||
(format s "[~a] " (get-universal-time))
|
||||
(apply #'format s msg args)
|
||||
(terpri s)
|
||||
(finish-output s))))
|
||||
|
||||
(defun message-queue-push (msg)
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(setf *incoming* (append *incoming* (list msg)))))
|
||||
|
||||
(defun message-queue-drain ()
|
||||
(bt:with-lock-held (*queue-lock*)
|
||||
(let ((msgs *incoming*))
|
||||
(setf *incoming* nil)
|
||||
msgs)))
|
||||
|
||||
(defun chat-render (win h)
|
||||
(when (and win (integerp h))
|
||||
(clear win)
|
||||
(box win 0 0)
|
||||
(let* ((view-height (- h 2))
|
||||
(history (copy-list *chat-history*))
|
||||
(len (length history))
|
||||
(num-to-draw (min len view-height))
|
||||
(slice (subseq history 0 num-to-draw)))
|
||||
(loop for i from 0 below num-to-draw
|
||||
for msg in (reverse slice)
|
||||
do (when msg
|
||||
(add-string win (format nil "│ ~a" msg) :y (1+ i) :x 2))))
|
||||
(refresh win)))
|
||||
|
||||
(defun input-backspace ()
|
||||
(pop *input-buffer*))
|
||||
|
||||
(defun input-submit (stream)
|
||||
(let ((cmd (coerce (reverse *input-buffer*) 'string)))
|
||||
(setf *input-buffer* nil)
|
||||
(log-debug "SUBMITTING: '~a'" cmd)
|
||||
(when (> (length cmd) 0)
|
||||
(push (format nil "⬆ ~a" cmd) *chat-history*)
|
||||
(handler-case
|
||||
(progn
|
||||
(if (and stream (open-stream-p stream))
|
||||
(let* ((msg (list :TYPE :EVENT
|
||||
:META (list :SOURCE :tui)
|
||||
:PAYLOAD (list :SENSOR :user-input :TEXT cmd)))
|
||||
(payload (format nil "~s" msg))
|
||||
(len (length payload)))
|
||||
(format stream "~6,'0x~a" len payload)
|
||||
(finish-output stream)
|
||||
(log-debug "SENT WIRE: ~a" payload))
|
||||
(push "ERROR: Not connected." *chat-history*)))
|
||||
(error (c)
|
||||
(log-debug "SEND ERROR: ~a" c)
|
||||
(push (format nil "ERROR: ~a" c) *chat-history*)
|
||||
(setf *is-running* nil))))
|
||||
(when (string= cmd "/exit") (setf *is-running* nil))
|
||||
(when (string= cmd "/clear") (setf *chat-history* nil))))
|
||||
|
||||
(defun reader-start (stream)
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop while *is-running* do
|
||||
(handler-case
|
||||
(let* ((len-buf (make-string 6))
|
||||
(count (read-sequence len-buf stream)))
|
||||
(if (= count 6)
|
||||
(let* ((msg-len (parse-integer len-buf :radix 16))
|
||||
(msg-buf (make-string msg-len)))
|
||||
(read-sequence msg-buf stream)
|
||||
(log-debug "DAEMON MSG: ~a" msg-buf)
|
||||
(let ((msg (read-from-string msg-buf)))
|
||||
(let ((payload (getf msg :payload)))
|
||||
(cond
|
||||
((eq (getf payload :action) :handshake)
|
||||
(message-queue-push "* Connected *"))
|
||||
(t
|
||||
(let ((text (or (getf payload :text) (format nil "~a" payload))))
|
||||
(message-queue-push (format nil "⬇ ~a" text))))))))
|
||||
(sleep 0.05)))
|
||||
(error (c)
|
||||
(when *is-running*
|
||||
(log-debug "READER ERROR: ~a" c)
|
||||
(message-queue-push "ERROR: Connection lost.")
|
||||
(setf *is-running* nil))))))
|
||||
:name "passepartout-tui-reader"))
|
||||
|
||||
(defun main ()
|
||||
(log-debug "=== START ===")
|
||||
(handler-case
|
||||
(setf *socket* (usocket:socket-connect *daemon-host* *daemon-port*))
|
||||
(error (e) (format t "Offline: ~a~%" e) (return-from main)))
|
||||
(setf *stream* (usocket:socket-stream *socket*))
|
||||
|
||||
(unwind-protect
|
||||
(with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t)
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(chat-h (- h 4))
|
||||
(chat-win (make-instance 'window :height chat-h :width (- w 2) :y 1 :x 1))
|
||||
(input-win (make-instance 'window :height 1 :width (- w 2) :y (- h 2) :x 1)))
|
||||
(setf (input-blocking input-win) nil)
|
||||
(reader-start *stream*)
|
||||
(loop :while *is-running* :do
|
||||
(let ((msgs (message-queue-drain)))
|
||||
(when msgs
|
||||
(dolist (m msgs) (push m *chat-history*))
|
||||
(chat-render chat-win chat-h)))
|
||||
(let ((ch (get-char input-win)))
|
||||
(when (and ch (not (equal ch -1)))
|
||||
(log-debug "KEY: ~s" ch)
|
||||
(cond
|
||||
((or (eql ch 10) (eql ch 13) (eq ch :enter) (eql ch #\Newline) (eql ch #\Return))
|
||||
(input-submit *stream*)
|
||||
(chat-render chat-win chat-h))
|
||||
((or (eql ch 127) (eql ch 8) (eq ch :backspace) (eql ch #\Backspace))
|
||||
(input-backspace))
|
||||
((characterp ch)
|
||||
(push ch *input-buffer*))
|
||||
((integerp ch)
|
||||
(let ((converted (code-char ch)))
|
||||
(when (graphic-char-p converted)
|
||||
(push converted *input-buffer*))))))
|
||||
(clear input-win)
|
||||
(add-string input-win (format nil "▶ ~a" (coerce (reverse *input-buffer*) 'string)) :y 0 :x 1)
|
||||
(refresh input-win))
|
||||
(sleep 0.01))))
|
||||
(setf *is-running* nil)
|
||||
(when *socket* (ignore-errors (usocket:socket-close *socket*)))))
|
||||
223
lisp/programming-lisp.lisp
Normal file
223
lisp/programming-lisp.lisp
Normal file
@@ -0,0 +1,223 @@
|
||||
(defun lisp-structural-check (code)
|
||||
"Checks if parentheses are balanced and the code is readable."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values t nil))
|
||||
(error (c)
|
||||
(values nil (format nil "Reader Error: ~a" c)))))
|
||||
|
||||
(defun lisp-syntactic-check (code)
|
||||
"Checks for valid Lisp syntax beyond just balanced parentheses."
|
||||
(lisp-structural-check code))
|
||||
|
||||
(defun lisp-semantic-check (code)
|
||||
"Checks for potentially unsafe forms."
|
||||
(let ((unsafe-tokens '("eval" "load" "uiop:run-program" "sb-ext:run-program" "cl-user::eval")))
|
||||
(loop for token in unsafe-tokens
|
||||
when (search token (string-downcase code))
|
||||
do (return-from lisp-semantic-check (values nil (format nil "Unsafe form detected: ~a" token))))
|
||||
(values t nil)))
|
||||
|
||||
(defun lisp-validate (code &key (strict t))
|
||||
"Unified validation gate for Lisp code."
|
||||
(multiple-value-bind (struct-ok struct-err) (lisp-structural-check code)
|
||||
(unless struct-ok
|
||||
(return-from lisp-validate (list :status :error :reason struct-err)))
|
||||
(when strict
|
||||
(multiple-value-bind (sem-ok sem-err) (lisp-semantic-check code)
|
||||
(unless sem-ok
|
||||
(return-from lisp-validate (list :status :error :reason sem-err)))))
|
||||
(list :status :success)))
|
||||
|
||||
(defun lisp-eval (code-string &key (package :passepartout))
|
||||
"Evaluates a Lisp string and captures its output/results."
|
||||
(let ((out (make-string-output-stream))
|
||||
(err (make-string-output-stream)))
|
||||
(handler-case
|
||||
(let* ((*standard-output* out)
|
||||
(*error-output* err)
|
||||
(*package* (or (find-package package) (find-package :passepartout)))
|
||||
(result (with-input-from-string (s code-string)
|
||||
(let ((last-val nil))
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (setf last-val (eval form)))
|
||||
last-val))))
|
||||
(list :status :success
|
||||
:result (format nil "~a" result)
|
||||
:output (get-output-stream-string out)
|
||||
:error (get-output-stream-string err)))
|
||||
(error (c)
|
||||
(list :status :error
|
||||
:reason (format nil "~a" c)
|
||||
:output (get-output-stream-string out)
|
||||
:error (get-output-stream-string err))))))
|
||||
|
||||
(defun lisp-format (code-string)
|
||||
"Attempts to format Lisp code using Emacs batch mode if available."
|
||||
(handler-case
|
||||
(let ((tmp-file "/tmp/oc-format-temp.lisp"))
|
||||
(uiop:with-output-file (s tmp-file :if-exists :supersede)
|
||||
(format s "~a" code-string))
|
||||
(multiple-value-bind (out err code)
|
||||
(uiop:run-program (list "emacs" "--batch" tmp-file
|
||||
"--eval" "(indent-region (point-min) (point-max))"
|
||||
"--eval" "(princ (buffer-string))")
|
||||
:output :string :error-output :string :ignore-error-status t)
|
||||
(if (= code 0)
|
||||
out
|
||||
(progn
|
||||
(log-message "FORMAT ERROR: ~a" err)
|
||||
code-string))))
|
||||
(error (c)
|
||||
(log-message "FORMAT EXCEPTION: ~a" c)
|
||||
code-string)))
|
||||
|
||||
(defun lisp-extract (code function-name)
|
||||
"Extracts the definition of a specific function from a code string."
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
when (and (listp form)
|
||||
(symbolp (car form))
|
||||
(member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) function-name))
|
||||
do (return-from lisp-extract (format nil "~s" form))))
|
||||
nil))
|
||||
|
||||
(defun lisp-wrap (code target-name wrapper-symbol)
|
||||
"Wraps a specific form in a wrapper form (e.g., wrap in a let)."
|
||||
(let ((*read-eval* nil) (results nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (if (and (listp form)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) target-name))
|
||||
(push (list wrapper-symbol form) results)
|
||||
(push form results))))
|
||||
(format nil "~{~s~^~%~%~}" (nreverse results))))
|
||||
|
||||
(defun lisp-list-definitions (code)
|
||||
"Returns a list of names for all top-level definitions (defun, defmacro, etc.)."
|
||||
(let ((*read-eval* nil) (names nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
when (and (listp form)
|
||||
(symbolp (car form))
|
||||
(member (symbol-name (car form))
|
||||
'("DEFUN" "DEFMACRO" "DEFMETHOD" "DEFVAR" "DEFPARAMETER")
|
||||
:test #'string-equal)
|
||||
(symbolp (second form)))
|
||||
do (push (second form) names)))
|
||||
(nreverse names)))
|
||||
|
||||
(defun lisp-inject (code target-name new-form-string)
|
||||
"Injects a new form into the body of a targeted definition."
|
||||
(let ((*read-eval* nil)
|
||||
(new-form (read-from-string new-form-string))
|
||||
(results nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (if (and (listp form)
|
||||
(symbolp (car form))
|
||||
(member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) target-name))
|
||||
(push (append form (list new-form)) results)
|
||||
(push form results))))
|
||||
(format nil "~{~s~^~%~%~}" (nreverse results))))
|
||||
|
||||
(defun lisp-slurp (code target-name form-to-slurp-string)
|
||||
"Adds a form to the end of a named list or definition (Paredit slurp)."
|
||||
(let ((*read-eval* nil)
|
||||
(to-slurp (read-from-string form-to-slurp-string))
|
||||
(results nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (if (and (listp form)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) target-name))
|
||||
(push (append form (list to-slurp)) results)
|
||||
(push form results))))
|
||||
(format nil "~{~s~^~%~%~}" (nreverse results))))
|
||||
|
||||
(defskill :passepartout-programming-lisp
|
||||
:priority 400
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(defpackage :passepartout-utils-lisp-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-lisp-suite))
|
||||
|
||||
(in-package :passepartout-utils-lisp-tests)
|
||||
|
||||
(def-suite utils-lisp-suite
|
||||
:description "Tests for the Lisp Validator structural, syntactic, and semantic gates")
|
||||
|
||||
(in-suite utils-lisp-suite)
|
||||
|
||||
(test structural-balanced
|
||||
(is (eq t (passepartout:lisp-structural-check "(+ 1 2)"))))
|
||||
|
||||
(test structural-unbalanced-open
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "(+ 1 2")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test structural-unbalanced-close
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "+ 1 2)")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test syntactic-valid
|
||||
(is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-safe
|
||||
(is (eq t (passepartout:lisp-semantic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-blocked-eval
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))")
|
||||
(is (null ok))
|
||||
(is (search "Unsafe" reason))))
|
||||
|
||||
(test unified-success
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t)))
|
||||
(is (eq (getf result :status) :success))))
|
||||
|
||||
(test unified-failure
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
(test eval-basic
|
||||
(let ((result (passepartout:lisp-eval "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (string= (getf result :result) "3"))))
|
||||
|
||||
(test structural-extract
|
||||
(let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))")
|
||||
(extracted (passepartout:lisp-extract code "hello")))
|
||||
(is (not (null extracted)))
|
||||
(let ((form (read-from-string extracted)))
|
||||
(is (eq (car form) 'DEFUN))
|
||||
(is (eq (second form) 'HELLO)))))
|
||||
|
||||
(test list-definitions
|
||||
(let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)"))
|
||||
(let ((names (passepartout:lisp-list-definitions code)))
|
||||
(is (member 'FOO names))
|
||||
(is (member 'BAR names))
|
||||
(is (member '*BAZ* names)))))
|
||||
|
||||
(test structural-inject
|
||||
(let* ((code "(defun my-fun (x) (print x))")
|
||||
(injected (passepartout:lisp-inject code "my-fun" "(finish-output)")))
|
||||
(let ((form (read-from-string injected)))
|
||||
(is (equal (last form) '((FINISH-OUTPUT)))))))
|
||||
|
||||
(test structural-slurp
|
||||
(let* ((code "(defun work () (step-1))")
|
||||
(slurped (passepartout:lisp-slurp code "work" "(step-2)")))
|
||||
(let ((form (read-from-string slurped)))
|
||||
(is (equal (last form) '((STEP-2)))))))
|
||||
64
lisp/programming-literate.lisp
Normal file
64
lisp/programming-literate.lisp
Normal file
@@ -0,0 +1,64 @@
|
||||
(defun literate-extract-lisp-blocks (content)
|
||||
"Extracts all #+begin_src lisp ... #+end_src blocks from Org CONTENT.
|
||||
Returns a list of block strings."
|
||||
(let ((lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(blocks nil)
|
||||
(in-block nil)
|
||||
(current-block nil))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space) line)))
|
||||
(cond
|
||||
((uiop:string-prefix-p "#+begin_src lisp" trimmed)
|
||||
(setf in-block t current-block nil))
|
||||
((uiop:string-prefix-p "#+end_src" trimmed)
|
||||
(when in-block
|
||||
(push (format nil "~{~a~^~%~}" (nreverse current-block)) blocks)
|
||||
(setf in-block nil current-block nil)))
|
||||
(in-block
|
||||
(push line current-block)))))
|
||||
(nreverse blocks)))
|
||||
|
||||
(defun literate-block-balance-check (org-file)
|
||||
"Verifies that all Lisp source blocks in an Org file have balanced parentheses.
|
||||
Returns T if all blocks pass validation, or an error string listing failures."
|
||||
(when (not (uiop:file-exists-p org-file))
|
||||
(return-from literate-block-balance-check
|
||||
(format nil "Org file not found: ~a" org-file)))
|
||||
(let* ((content (uiop:read-file-string org-file))
|
||||
(blocks (literate-extract-lisp-blocks content))
|
||||
(failures nil))
|
||||
(if (null blocks)
|
||||
t
|
||||
(progn
|
||||
(loop for i from 0
|
||||
for block in blocks
|
||||
for (ok reason) = (multiple-value-list
|
||||
(lisp-structural-check block))
|
||||
unless ok
|
||||
do (push (format nil "Block ~d: ~a" (1+ i) reason) failures))
|
||||
(if failures
|
||||
(format nil "Unbalanced blocks in ~a:~%~{~a~^~%~}" org-file failures)
|
||||
t)))))
|
||||
|
||||
(defun literate-tangle-sync-check (org-file lisp-file)
|
||||
"Verifies that the .lisp file matches the tangled output of the .org file.
|
||||
Compares the concatenation of all lisp blocks from the Org file against the
|
||||
contents of the Lisp file. Returns T if they match, or an error message."
|
||||
(when (not (uiop:file-exists-p org-file))
|
||||
(return-from literate-tangle-sync-check
|
||||
(format nil "Org file not found: ~a" org-file)))
|
||||
(when (not (uiop:file-exists-p lisp-file))
|
||||
(return-from literate-tangle-sync-check
|
||||
(format nil "Lisp file not found: ~a" lisp-file)))
|
||||
(let* ((org-content (uiop:read-file-string org-file))
|
||||
(org-blocks (literate-extract-lisp-blocks org-content))
|
||||
(tangled (format nil "~{~a~^~%~%~}" org-blocks))
|
||||
(lisp-content (uiop:read-file-string lisp-file)))
|
||||
(if (string= (string-trim '(#\Space #\Newline) tangled)
|
||||
(string-trim '(#\Space #\Newline) lisp-content))
|
||||
t
|
||||
(format nil "Tangle sync mismatch: ~a does not match ~a" org-file lisp-file))))
|
||||
|
||||
(defskill :passepartout-programming-literate
|
||||
:priority 300
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
240
lisp/programming-org.lisp
Normal file
240
lisp/programming-org.lisp
Normal file
@@ -0,0 +1,240 @@
|
||||
(defun org-filetags-extract (content)
|
||||
"Extracts the list of tags from a #+FILETAGS: line."
|
||||
(let ((lines (uiop:split-string content :separator '(#\Newline))))
|
||||
(dolist (line lines)
|
||||
(when (uiop:string-prefix-p "#+FILETAGS:" (string-trim '(#\Space) line))
|
||||
(let ((tag-str (string-trim " :" (subseq (string-trim '(#\Space) line) 10))))
|
||||
(return-from org-filetags-extract
|
||||
(mapcar (lambda (tag) (format nil ":~a" (string-trim '(#\Space) tag)))
|
||||
(uiop:split-string tag-str :separator '(#\space #\tab))))))))
|
||||
nil)
|
||||
|
||||
(defun org-privacy-tag-p (tags-list)
|
||||
"Returns T if any tag in TAGS-LIST matches bouncer-privacy-tags."
|
||||
(let ((privacy-tags (symbol-value (find-symbol "BOUNCER-PRIVACY-TAGS" :passepartout))))
|
||||
(when (and tags-list privacy-tags)
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private-tag)
|
||||
(string-equal (string-trim '(#\: #\space) tag)
|
||||
(string-trim '(#\: #\space) private-tag))
|
||||
privacy-tags))
|
||||
tags-list)))))
|
||||
|
||||
(defun org-privacy-strip (content)
|
||||
"Removes Org headlines whose :TAGS: property contains a privacy-filtered tag.
|
||||
Returns the filtered content as a string."
|
||||
(let* ((lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(result-lines nil)
|
||||
(skip-depth nil)
|
||||
(current-tags nil)
|
||||
(in-properties nil))
|
||||
(dolist (line lines)
|
||||
(cond
|
||||
(skip-depth
|
||||
;; We're inside a skipped subtree
|
||||
(when (and (uiop:string-prefix-p "*" (string-trim '(#\Space) line))
|
||||
(<= (length (string-trim '(#\Space) line)) skip-depth))
|
||||
(setf skip-depth nil)))
|
||||
((uiop:string-prefix-p ":PROPERTIES:" (string-trim '(#\Space) line))
|
||||
(setf in-properties t)
|
||||
(push line result-lines))
|
||||
((uiop:string-prefix-p ":END:" (string-trim '(#\Space) line))
|
||||
(setf in-properties nil)
|
||||
(when current-tags
|
||||
(when (org-privacy-tag-p (reverse current-tags))
|
||||
(setf skip-depth
|
||||
(length (car (last result-lines
|
||||
(1+ (position-if
|
||||
(lambda (l)
|
||||
(uiop:string-prefix-p "*" (string-trim '(#\Space) l)))
|
||||
(reverse result-lines))))))))
|
||||
(setf current-tags nil))
|
||||
(push line result-lines))
|
||||
((and in-properties (uiop:string-prefix-p ":TAGS:" (string-trim '(#\Space) line)))
|
||||
(let ((tag-val (string-trim '(#\Space) (subseq (string-trim '(#\Space) line) 6))))
|
||||
(setf current-tags (uiop:split-string tag-val :separator '(#\space #\tab))))
|
||||
(push line result-lines))
|
||||
(t
|
||||
(push line result-lines))))
|
||||
(format nil "~{~a~%~}" (nreverse result-lines))))
|
||||
|
||||
(defun org-read-file (filepath)
|
||||
"Reads an Org file into a string, applying privacy filtering."
|
||||
(let* ((raw (uiop:read-file-string filepath))
|
||||
(filetags (org-filetags-extract raw)))
|
||||
(if (org-privacy-tag-p filetags)
|
||||
(progn
|
||||
(log-message "UTILS-ORG: Blocked read of ~a — file-level privacy tag(s) ~a" filepath filetags)
|
||||
nil)
|
||||
(org-privacy-strip raw))))
|
||||
|
||||
(defun org-write-file (filepath content)
|
||||
"Writes content to an Org file."
|
||||
(uiop:with-output-file (s filepath :if-exists :supersede)
|
||||
(format s "~a" content)))
|
||||
|
||||
(defun org-id-generate ()
|
||||
"Generates a new UUID for an Org node."
|
||||
(string-downcase (format nil "~a" (uuid:make-v4-uuid))))
|
||||
|
||||
(defun org-id-format (id)
|
||||
"Ensures the ID has the 'id:' prefix."
|
||||
(if (uiop:string-prefix-p "id:" id)
|
||||
id
|
||||
(format nil "id:~a" id)))
|
||||
|
||||
(defun org-property-set (ast target-id property value)
|
||||
"Recursively sets a property on a headline with a matching ID in the AST."
|
||||
(let ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(contents (getf ast :contents)))
|
||||
(when (and (eq type :HEADLINE) (string= (getf props :ID) target-id))
|
||||
(setf (getf (getf ast :properties) property) value)
|
||||
(return-from org-property-set t))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(when (org-property-set child target-id property value)
|
||||
(return-from org-property-set t)))))
|
||||
nil)
|
||||
|
||||
(defun org-todo-set (ast target-id status)
|
||||
"Sets the TODO status of a headline in the AST."
|
||||
(org-property-set ast target-id :TODO status))
|
||||
|
||||
(defun org-headline-add (ast parent-id title)
|
||||
"Adds a new headline as a child of the parent-id in the AST."
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (getf props :ID))
|
||||
(contents (getf ast :contents)))
|
||||
(when (and (eq type :HEADLINE) (string= id parent-id))
|
||||
(let ((new-node (list :type :HEADLINE
|
||||
:properties (list :ID (org-id-format (org-id-generate))
|
||||
:TITLE title)
|
||||
:contents nil)))
|
||||
(setf (getf ast :contents) (append contents (list new-node)))
|
||||
(return-from org-headline-add t)))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(when (org-headline-add child parent-id title)
|
||||
(return-from org-headline-add t)))))
|
||||
nil)
|
||||
|
||||
(defun org-headline-find-by-id (ast id)
|
||||
"Finds a headline by its ID in the AST."
|
||||
(let ((props (getf ast :properties)))
|
||||
(when (string= (getf props :ID) id)
|
||||
(return-from org-headline-find-by-id ast))
|
||||
(dolist (child (getf ast :contents))
|
||||
(when (listp child)
|
||||
(let ((found (org-headline-find-by-id child id)))
|
||||
(when found (return-from org-headline-find-by-id found)))))
|
||||
nil))
|
||||
|
||||
(defun org-headline-find-by-title (ast title)
|
||||
"Finds a headline by its title in the AST."
|
||||
(let ((props (getf ast :properties)))
|
||||
(when (string-equal (getf props :TITLE) title)
|
||||
(return-from org-headline-find-by-title ast))
|
||||
(dolist (child (getf ast :contents))
|
||||
(when (listp child)
|
||||
(let ((found (org-headline-find-by-title child title)))
|
||||
(when found (return-from org-headline-find-by-title found)))))
|
||||
nil))
|
||||
|
||||
(defun org-modify (filepath old-text new-text)
|
||||
"Replaces all occurrences of OLD-TEXT with NEW-TEXT in filepath.
|
||||
Returns T if OLD-TEXT was found and replaced, nil if not found."
|
||||
(when (not (uiop:file-exists-p filepath))
|
||||
(log-message "UTILS-ORG: org-modify: file not found: ~a" filepath)
|
||||
(return-from org-modify nil))
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(pos (search old-text content :test #'string=)))
|
||||
(unless pos
|
||||
(log-message "UTILS-ORG: org-modify: text not found in ~a" filepath)
|
||||
(return-from org-modify nil))
|
||||
(let ((modified (cl-ppcre:regex-replace-all
|
||||
(cl-ppcre:quote-meta-chars old-text)
|
||||
content new-text)))
|
||||
(org-write-file filepath modified)
|
||||
(log-message "UTILS-ORG: Modified ~a (~d chars replaced)" filepath (length old-text))
|
||||
t)))
|
||||
|
||||
(defun org-ast-render (ast &key (depth 1))
|
||||
"Converts a plist AST node back to Org text.
|
||||
AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
:contents (child-ast ...))"
|
||||
(let* ((type (getf ast :TYPE))
|
||||
(props (getf ast :properties))
|
||||
(title (or (getf props :TITLE) "Untitled"))
|
||||
(tags (getf props :TAGS))
|
||||
(todo (getf props :TODO-STATE))
|
||||
(children (getf ast :contents))
|
||||
(raw-content (getf ast :raw-content))
|
||||
(stars (make-string depth :initial-element #\*))
|
||||
(output ""))
|
||||
(unless (eq type :HEADLINE)
|
||||
(return-from org-ast-render (or raw-content "")))
|
||||
;; Headline
|
||||
(setf output (format nil "~a~@[ ~a~] ~a" stars todo title))
|
||||
(when tags
|
||||
(let ((tag-str (format nil "~{~a~^:~}" (mapcar (lambda (t) (string-trim '(#\:) t)) tags))))
|
||||
(setf output (concatenate 'string output (format nil " :~a::~%" tag-str))))
|
||||
(setf output (concatenate 'string output (string #\Newline))))
|
||||
(unless tags
|
||||
(setf output (concatenate 'string output (string #\Newline))))
|
||||
;; Property drawer
|
||||
(setf output (concatenate 'string output ":PROPERTIES:" (string #\Newline)))
|
||||
(loop for (k v) on props by #'cddr
|
||||
do (unless (or (eq k :TITLE) (eq k :TAGS))
|
||||
(setf output (concatenate 'string output
|
||||
(format nil ":~a: ~a~%" k v)))))
|
||||
(setf output (concatenate 'string output ":END:" (string #\Newline)))
|
||||
;; Content
|
||||
(when raw-content
|
||||
(setf output (concatenate 'string output raw-content (string #\Newline))))
|
||||
;; Children
|
||||
(dolist (child children)
|
||||
(when (listp child)
|
||||
(setf output (concatenate 'string output
|
||||
(org-ast-render child :depth (1+ depth))))))
|
||||
output))
|
||||
|
||||
(defskill :passepartout-programming-org
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(defpackage :passepartout-utils-org-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-org-suite))
|
||||
|
||||
(in-package :passepartout-utils-org-tests)
|
||||
|
||||
(def-suite utils-org-suite
|
||||
:description "Tests for Utils Org skill.")
|
||||
|
||||
(in-suite utils-org-suite)
|
||||
|
||||
(test id-generation
|
||||
(let ((id1 (org-id-generate))
|
||||
(id2 (org-id-generate)))
|
||||
(is (plusp (length id1)))
|
||||
(is (not (string= id1 id2)))))
|
||||
|
||||
(test id-format
|
||||
(let ((formatted (org-id-format "abc12345")))
|
||||
(is (search "id:" formatted))))
|
||||
|
||||
(test property-setter
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:test123" :TITLE "Test")
|
||||
:contents nil)))
|
||||
(org-property-set ast "id:test123" :STATUS "ACTIVE")
|
||||
(is (string= (getf (getf ast :properties) :STATUS) "ACTIVE"))))
|
||||
|
||||
(test todo-setter
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:todo001" :TITLE "Task")
|
||||
:contents nil)))
|
||||
(org-todo-set ast "id:todo001" "DONE")
|
||||
(is (string= (getf (getf ast :properties) :TODO) "DONE"))))
|
||||
124
lisp/programming-repl.lisp
Normal file
124
lisp/programming-repl.lisp
Normal file
@@ -0,0 +1,124 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *repl-package* :passepartout
|
||||
"Default package for REPL evaluations.")
|
||||
|
||||
(defvar *repl-history* nil
|
||||
"History of evaluated forms for session continuity.")
|
||||
|
||||
(defvar *repl-variables* (make-hash-table :test #'eq)
|
||||
"Cache of bound variables for inspection.")
|
||||
|
||||
(defun repl-eval (code-string &key (package *repl-package*))
|
||||
"Evaluate Lisp code and return (values result output error).
|
||||
- result: the return value as string
|
||||
- output: captured stdout
|
||||
- error: error message or nil on success"
|
||||
(let ((out (make-string-output-stream))
|
||||
(err (make-string-output-stream))
|
||||
(pkg (or (find-package package) (find-package :passepartout))))
|
||||
(handler-case
|
||||
(let* ((*standard-output* out)
|
||||
(*error-output* err)
|
||||
(*package* pkg)
|
||||
(*read-eval* nil)
|
||||
(result nil))
|
||||
(with-input-from-string (s code-string)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (setf result (eval form))))
|
||||
(push code-string *repl-history*)
|
||||
(values
|
||||
(format nil "~a" result)
|
||||
(get-output-stream-string out)
|
||||
nil))
|
||||
(error (c)
|
||||
(values
|
||||
nil
|
||||
(get-output-stream-string out)
|
||||
(format nil "~a" c))))))
|
||||
|
||||
(defun repl-inspect (symbol-name &key (package *repl-package*))
|
||||
"Inspect a variable's value and structure."
|
||||
(let* ((pkg (or (find-package package) (find-package :passepartout)))
|
||||
(sym (find-symbol (string-upcase symbol-name) pkg)))
|
||||
(cond
|
||||
((null sym)
|
||||
(format nil "Symbol ~a not found in package ~a" symbol-name package))
|
||||
((boundp sym)
|
||||
(let ((val (symbol-value sym)))
|
||||
(format nil "~a = ~a~%Type: ~a~%~%"
|
||||
sym val (type-of val))))
|
||||
((fboundp sym)
|
||||
(format nil "~a is a function~%Args: ~a~%"
|
||||
sym (documentation sym 'function)))
|
||||
(t
|
||||
(format nil "~a is unbound" symbol-name)))))
|
||||
|
||||
(defun repl-list-vars (&key (package *repl-package*))
|
||||
"List all bound variables in the package."
|
||||
(let* ((pkg (or (find-package package) (find-package :passepartout)))
|
||||
(vars nil))
|
||||
(do-symbols (sym pkg)
|
||||
(when (boundp sym)
|
||||
(push (format nil "~a" sym) vars)))
|
||||
(sort vars #'string<)))
|
||||
|
||||
(defun repl-load-file (filepath)
|
||||
"Load a Lisp file into the current image."
|
||||
(handler-case
|
||||
(progn
|
||||
(load filepath)
|
||||
(format nil "Loaded ~a" filepath))
|
||||
(error (c)
|
||||
(format nil "Error loading ~a: ~a" filepath c))))
|
||||
|
||||
(defun repl-set-package (package-name)
|
||||
"Set the default package for REPL evaluations."
|
||||
(let ((pkg (find-package (string-upcase package-name))))
|
||||
(if pkg
|
||||
(setf *repl-package* pkg)
|
||||
(format nil "Package ~a not found" package-name))))
|
||||
|
||||
(defun repl-help ()
|
||||
"Return available REPL commands."
|
||||
(format nil "~%
|
||||
REPL Skill Commands:
|
||||
-------------------
|
||||
(repl-eval \"code\" :package :passepartout)
|
||||
- Evaluate Lisp code, returns (values result output error)
|
||||
|
||||
(repl-inspect \"symbol\" :package :passepartout)
|
||||
- Inspect a variable or function
|
||||
|
||||
(repl-list-vars :package :passepartout)
|
||||
- List all bound variables
|
||||
|
||||
(repl-load-file \"/path/to/file.lisp\")
|
||||
- Load a file into the image
|
||||
|
||||
(repl-set-package :package-name)
|
||||
- Switch default package
|
||||
|
||||
(repl-help)
|
||||
- Show this message
|
||||
"))
|
||||
|
||||
(defun repl-mandate (context)
|
||||
"Returns REPL-first engineering mandate when context involves code editing."
|
||||
(let ((raw (or (proto-get (proto-get context :payload) :text) "")))
|
||||
(when (or (search "org-skill-" raw :test #'char-equal)
|
||||
(and (search ".org" raw :test #'char-equal)
|
||||
(or (search "defun" raw :test #'char-equal)
|
||||
(search "tangle" raw :test #'char-equal)
|
||||
(search "write-file" raw :test #'char-equal)
|
||||
(search "lisp" raw :test #'char-equal)))
|
||||
(search "defun " raw :test #'char-equal)
|
||||
(search "repl-eval" raw :test #'char-equal)
|
||||
(search "validate" raw :test #'char-equal))
|
||||
(format nil "~%REPL-FIRST MANDATE:~%Before writing any defun to an Org file, prototype it in the REPL first. Set :repl-verified t on the write action. On rejection, fix the error and retry.~%"))))
|
||||
|
||||
(defskill :passepartout-programming-repl
|
||||
:priority 200
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil)
|
||||
:system-prompt-augment #'repl-mandate)
|
||||
21
lisp/programming-standards.lisp
Normal file
21
lisp/programming-standards.lisp
Normal file
@@ -0,0 +1,21 @@
|
||||
(defun standards-git-clean-p (dir)
|
||||
"Checks if a directory has uncommitted changes."
|
||||
(let ((status (uiop:run-program (list "git" "-C" (namestring dir) "status" "--porcelain")
|
||||
:output :string
|
||||
:ignore-error-status t)))
|
||||
(string= "" (string-trim '(#\Space #\Newline #\Tab) status))))
|
||||
|
||||
(defun standards-lisp-verify (code)
|
||||
"Enforces Lisp structural and semantic standards using utils-lisp."
|
||||
(let ((result (utils-lisp-validate code :strict t)))
|
||||
(if (eq (getf result :status) :success)
|
||||
t
|
||||
(error (getf result :reason)))))
|
||||
|
||||
(defun standards-lisp-format (code)
|
||||
"Ensures Lisp code adheres to formatting standards."
|
||||
(utils-lisp-format code))
|
||||
|
||||
(defskill :passepartout-programming-standards
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
327
lisp/security-dispatcher.lisp
Normal file
327
lisp/security-dispatcher.lisp
Normal file
@@ -0,0 +1,327 @@
|
||||
(defvar *dispatcher-network-whitelist*
|
||||
'("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")
|
||||
"Domains the Bouncer considers safe for outbound connections.")
|
||||
|
||||
(defvar *dispatcher-privacy-tags*
|
||||
(let ((env (uiop:getenv "PRIVACY_FILTER_TAGS")))
|
||||
(if env
|
||||
(uiop:split-string env :separator '(#\,))
|
||||
'("@personal")))
|
||||
"Tags marking content as private. Set via PRIVACY_FILTER_TAGS.")
|
||||
|
||||
(defvar *dispatcher-protected-paths*
|
||||
'(".env" ".env.example" ".env.local" ".env.production"
|
||||
"*credentials*" "*cred*"
|
||||
"*id_rsa*" "*id_dsa*" "*id_ecdsa*" "*id_ed25519*"
|
||||
"*.pem" "*.key" "*.p12" "*.pfx" "*.asc" "*.gpg" "*.pgp"
|
||||
"secring.*" "pubring.*" "private-keys-v1.d/*"
|
||||
"token*" "*secret*" "*token*"
|
||||
".netrc" ".git-credentials" "auth.json"
|
||||
".aws/credentials" ".aws/config"
|
||||
".kube/config" "kubeconfig"
|
||||
"*.cert" "*.crt" "*.csr"
|
||||
"*password*" "*passwd*")
|
||||
"Path patterns blocked from file reads.")
|
||||
|
||||
(defvar *dispatcher-exposure-patterns*
|
||||
'((:pem-key "-----BEGIN +(RSA|DSA|EC|OPENSSH|PGP) +PRIVATE +KEY *-----")
|
||||
(:pgp-key "-----BEGIN +PGP +PRIVATE +KEY +BLOCK-----")
|
||||
(:pgp-public "-----BEGIN +PGP +PUBLIC +KEY +BLOCK-----")
|
||||
(:openai-key "sk-[A-Za-z0-9-]{20,}")
|
||||
(:google-key "AIza[0-9A-Za-z_-]{35}")
|
||||
(:github-token "gh[pousr]_[A-Za-z0-9]{36,}")
|
||||
(:slack-token "xox[baprs]-[A-Za-z0-9-]{24,}")
|
||||
(:env-assignment "[A-Z_]+=[A-Za-z0-9+/=_\\-]{20,}")
|
||||
(:generic-secret "(api|secret|password|token)[ ]*[:=][ ]*[\"']?[A-Za-z0-9_\\-]{16,}"))
|
||||
"Named regex patterns for secret exposure detection.")
|
||||
|
||||
(defvar *dispatcher-shell-timeout* 30
|
||||
"Maximum seconds for a shell command before timeout.")
|
||||
|
||||
(defvar *dispatcher-shell-max-output* 100000
|
||||
"Maximum characters of shell output to capture.")
|
||||
|
||||
(defvar *dispatcher-shell-blocked*
|
||||
'((:destructive-rm "\\brm\\s+-rf\\s+/")
|
||||
(:destructive-dd "\\bdd\\s+if=")
|
||||
(:destructive-mkfs "\\bmkfs\\.")
|
||||
(:destructive-format "\\bmformat\\b")
|
||||
(:disk-wipe "\\bshred\\s+/dev/")
|
||||
(:disk-wipe-b "\\bwipefs\\s+/dev/")
|
||||
(:injection-backtick "`[^`]+`")
|
||||
(:injection-subshell "\\$\\([^)]+\\)"))
|
||||
"Destructive and injection patterns blocked in shell commands.")
|
||||
|
||||
(defun wildcard-match (pattern path)
|
||||
"Matches PATH against PATTERN where * matches any characters."
|
||||
(let ((regex (cl-ppcre:regex-replace-all
|
||||
"\\*" (cl-ppcre:quote-meta-chars pattern) ".*")))
|
||||
(cl-ppcre:scan regex path)))
|
||||
|
||||
(defun dispatcher-check-secret-path (filepath)
|
||||
"Returns the matching pattern if FILEPATH matches a protected path, nil otherwise."
|
||||
(when (and filepath (stringp filepath))
|
||||
(some (lambda (pattern)
|
||||
(when (wildcard-match pattern filepath)
|
||||
pattern))
|
||||
*dispatcher-protected-paths*)))
|
||||
|
||||
(defun dispatcher-exposure-scan (text)
|
||||
"Scans TEXT for patterns matching known secret formats.
|
||||
Returns a list of matched category keywords."
|
||||
(when (and text (stringp text) (> (length text) 0))
|
||||
(let ((matches nil))
|
||||
(dolist (entry *dispatcher-exposure-patterns*)
|
||||
(let ((name (first entry))
|
||||
(regex (second entry)))
|
||||
(when (cl-ppcre:scan regex text)
|
||||
(push name matches))))
|
||||
matches)))
|
||||
|
||||
(defun dispatcher-vault-scan (text)
|
||||
"Scans TEXT for known secrets from the vault."
|
||||
(when (and text (stringp text))
|
||||
(let ((found-secret nil))
|
||||
(maphash (lambda (key val)
|
||||
(when (and val (stringp val) (> (length val) 5))
|
||||
(when (search val text)
|
||||
(setf found-secret key))))
|
||||
*vault-memory*)
|
||||
found-secret)))
|
||||
|
||||
(defun dispatcher-check-privacy-tags (tags-list)
|
||||
"Returns T if any tag in TAGS-LIST matches a privacy filter tag."
|
||||
(when (and tags-list (listp tags-list))
|
||||
(some (lambda (tag)
|
||||
(some (lambda (private)
|
||||
(or (string-equal tag private)
|
||||
(search private tag :test #'string-equal)))
|
||||
*dispatcher-privacy-tags*))
|
||||
tags-list)))
|
||||
|
||||
(defun dispatcher-check-text-for-privacy (text)
|
||||
"Scans TEXT for leaked privacy-tagged content."
|
||||
(when (and text (stringp text))
|
||||
(let ((lower (string-downcase text)))
|
||||
(some (lambda (tag)
|
||||
(search (string-downcase tag) lower))
|
||||
*dispatcher-privacy-tags*))))
|
||||
|
||||
(defun org-blocks-extract (content)
|
||||
"Extracts concatenated Lisp code from #+begin_src lisp blocks in an Org string."
|
||||
(when (and content (stringp content))
|
||||
(let ((lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-block nil)
|
||||
(code ""))
|
||||
(dolist (line lines)
|
||||
(let ((clean (string-trim '(#\Space #\Tab) line)))
|
||||
(cond
|
||||
((search "#+begin_src lisp" clean)
|
||||
(setf in-block t))
|
||||
((search "#+end_src" clean)
|
||||
(setf in-block nil))
|
||||
(in-block
|
||||
(setf code (concatenate 'string code line (string #\Newline)))))))
|
||||
(when (> (length code) 0) code))))
|
||||
|
||||
(defun dispatcher-check-lisp-valid (filepath content)
|
||||
"Validates Lisp syntax when writing .lisp files or Org files with lisp blocks.
|
||||
Returns the validation result plist or nil if not applicable."
|
||||
(when (and content (stringp content) (> (length content) 0))
|
||||
(let ((to-validate
|
||||
(cond
|
||||
((uiop:string-suffix-p filepath ".lisp") content)
|
||||
((uiop:string-suffix-p filepath ".org") (org-blocks-extract content))
|
||||
(t nil))))
|
||||
(when to-validate
|
||||
(multiple-value-bind (valid-p err) (ignore-errors
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s (format nil "(progn ~a)" to-validate))
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values t nil)))
|
||||
(unless valid-p
|
||||
(list :status :error :reason err)))))))
|
||||
|
||||
(defun org-has-defuns-p (content)
|
||||
"Returns T if the Org content contains any #+begin_src lisp blocks with defuns."
|
||||
(when (and content (stringp content))
|
||||
(search "defun " content :test #'char-equal)))
|
||||
|
||||
(defun dispatcher-check-repl-verified (action filepath content)
|
||||
"Warns if writing a defun to an Org file without :repl-verified metadata."
|
||||
(let ((repl-verified (getf action :repl-verified)))
|
||||
(when (and filepath
|
||||
(uiop:string-suffix-p filepath ".org")
|
||||
(org-has-defuns-p content)
|
||||
(not repl-verified))
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text (format nil "Lint: Writing defun to ~a without :repl-verified flag. Did you prototype this in the REPL first?" filepath))))))
|
||||
|
||||
(defun dispatcher-check-shell-safety (cmd)
|
||||
"Checks a shell command for destructive patterns and injection vectors.
|
||||
Returns a list of matched pattern names or nil if safe."
|
||||
(when (and cmd (stringp cmd) (> (length cmd) 0))
|
||||
(let ((matches nil))
|
||||
(dolist (entry *dispatcher-shell-blocked*)
|
||||
(let ((name (first entry))
|
||||
(regex (second entry)))
|
||||
(when (cl-ppcre:scan regex cmd)
|
||||
(push name matches))))
|
||||
matches)))
|
||||
|
||||
(defun dispatcher-check-network-exfil (cmd)
|
||||
"Detects if CMD attempts to contact an unwhitelisted external host."
|
||||
(when (and cmd (stringp cmd))
|
||||
(multiple-value-bind (match regs)
|
||||
(cl-ppcre:scan-to-strings "(http|https|ftp)://([\\w\\.-]+)" cmd)
|
||||
(declare (ignore match))
|
||||
(when regs
|
||||
(let ((domain (aref regs 1)))
|
||||
(not (some (lambda (safe) (search safe domain))
|
||||
*dispatcher-network-whitelist*)))))))
|
||||
|
||||
(defun dispatcher-check (action context)
|
||||
"Security gate for high-risk actions.
|
||||
Vectors: lisp validation, secret path, secret content, vault secrets,
|
||||
privacy tags, privacy text, shell safety, network exfil, high-impact approval."
|
||||
(declare (ignore context))
|
||||
(let* ((target (proto-get action :target))
|
||||
(payload (proto-get action :payload))
|
||||
(text (or (proto-get payload :text) (proto-get action :text)))
|
||||
(filepath (or (proto-get payload :filepath)
|
||||
(when (equal (proto-get payload :tool) "read-file")
|
||||
(proto-get (proto-get payload :args) :filepath))
|
||||
(when (equal (proto-get payload :tool) "write-file")
|
||||
(proto-get (proto-get payload :args) :filepath))))
|
||||
(content (when filepath (proto-get (proto-get payload :args) :content)))
|
||||
(cmd (or (proto-get payload :cmd)
|
||||
(when (and (eq target :tool) (equal (proto-get payload :tool) "shell"))
|
||||
(proto-get (proto-get payload :args) :cmd))))
|
||||
(approved (proto-get action :approved))
|
||||
(tags (proto-get payload :tags))
|
||||
(lisp-valid (when (and filepath content (not approved))
|
||||
(dispatcher-check-lisp-valid filepath content)))
|
||||
(repl-lint (when (and filepath content (not approved))
|
||||
(dispatcher-check-repl-verified action filepath content))))
|
||||
(cond
|
||||
(approved action)
|
||||
|
||||
;; Vector 0: REPL verification lint (warn, don't block)
|
||||
(repl-lint
|
||||
(log-message "BOUNCER: ~a" (proto-get repl-lint :text))
|
||||
action)
|
||||
|
||||
;; Vector 1: Lisp syntax validation (block bad lisp writes)
|
||||
((and lisp-valid (eq (getf lisp-valid :status) :error))
|
||||
(log-message "LINT VIOLATION: Blocked write — lisp syntax error in ~a: ~a" filepath (getf lisp-valid :reason))
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text (format nil "Lisp syntax error in ~a: ~a. The write was blocked. Fix the parenthesis balance and retry." filepath (getf lisp-valid :reason)))))
|
||||
|
||||
;; Vector 2: File read to a protected secret path
|
||||
((and filepath (dispatcher-check-secret-path filepath))
|
||||
(let ((matched (dispatcher-check-secret-path filepath)))
|
||||
(log-message "SECURITY VIOLATION: Blocked read of protected path '~a' (matched: ~a)" filepath matched)
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text (format nil "Action blocked: Attempted read of protected path '~a'" filepath)))))
|
||||
|
||||
;; Vector 3: Content contains secret patterns
|
||||
((and text (dispatcher-exposure-scan text))
|
||||
(let ((matched (dispatcher-exposure-scan text)))
|
||||
(log-message "SECURITY VIOLATION: Content contains secret patterns: ~a" matched)
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text "Action blocked: Content contains potential secret exposure."))))
|
||||
|
||||
;; Vector 4: Content contains vault secrets
|
||||
((and text (dispatcher-vault-scan text))
|
||||
(let ((secret-name (dispatcher-vault-scan text)))
|
||||
(log-message "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name)
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
|
||||
|
||||
;; Vector 5: Privacy-tagged content in action
|
||||
((and tags (dispatcher-check-privacy-tags tags))
|
||||
(log-message "PRIVACY VIOLATION: Action contains privacy-tagged content")
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text "Action blocked: Content tagged with privacy filter.")))
|
||||
|
||||
;; Vector 6: Text leaks privacy tag names
|
||||
((and text (dispatcher-check-text-for-privacy text))
|
||||
(log-message "PRIVACY WARNING: Text may contain leaked private content")
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text "Action blocked: Text may reference private content.")))
|
||||
|
||||
;; Vector 7: Shell destructive/injection patterns
|
||||
((and cmd (dispatcher-check-shell-safety cmd))
|
||||
(let ((matched (dispatcher-check-shell-safety cmd)))
|
||||
(log-message "SHELL VIOLATION: Destructive or injection pattern in command: ~a" matched)
|
||||
(list :type :LOG
|
||||
:payload (list :level :error
|
||||
:text (format nil "Shell command blocked: contains unsafe pattern ~a" matched)))))
|
||||
|
||||
;; Vector 8: Network exfiltration
|
||||
((and (or (eq target :shell)
|
||||
(and (eq target :tool) (equal (proto-get payload :tool) "shell")))
|
||||
(dispatcher-check-network-exfil cmd))
|
||||
(log-message "SECURITY WARNING: External network call detected. Queuing for approval.")
|
||||
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
|
||||
|
||||
;; Vector 8: High-impact action approval
|
||||
((or (member target '(:shell))
|
||||
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=))
|
||||
(and (eq target :emacs) (eq (proto-get payload :action) :eval)))
|
||||
(log-message "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target))
|
||||
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
|
||||
(t action))))
|
||||
|
||||
(defun dispatcher-approvals-process ()
|
||||
"Scans for APPROVED flight plans and re-injects them."
|
||||
(let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED"))
|
||||
(found-any nil))
|
||||
(dolist (node approved-nodes)
|
||||
(let* ((attrs (org-object-attributes node))
|
||||
(tags (getf attrs :TAGS))
|
||||
(action-str (getf attrs :ACTION)))
|
||||
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str)
|
||||
(log-message "BOUNCER: Found approved flight plan '~a'. Re-injecting..." (org-object-id node))
|
||||
(let ((action (ignore-errors (read-from-string action-str))))
|
||||
(when action
|
||||
(setf (getf action :approved) t)
|
||||
(inject-stimulus action)
|
||||
(setf (getf (org-object-attributes node) :TODO) "DONE")
|
||||
(setq found-any t))))))
|
||||
found-any))
|
||||
|
||||
(defun dispatcher-flight-plan-create (blocked-action)
|
||||
"Creates a Flight Plan node for manual approval."
|
||||
(let ((id (org-id-new)))
|
||||
(log-message "BOUNCER: Creating flight plan node '~a'..." id)
|
||||
(list :type :REQUEST :target :emacs
|
||||
:payload (list :action :insert-node :id id
|
||||
:attributes (list :TITLE "Flight Plan: High-Risk Action"
|
||||
:TODO "PLAN" :TAGS '("FLIGHT_PLAN")
|
||||
:ACTION (format nil "~s" blocked-action))))))
|
||||
|
||||
(defun dispatcher-gate (action context)
|
||||
"Main deterministic gate for the Bouncer skill."
|
||||
(let* ((payload (getf context :payload))
|
||||
(sensor (getf payload :sensor)))
|
||||
(case sensor
|
||||
(:approval-required
|
||||
(dispatcher-flight-plan-create (getf payload :action)))
|
||||
(:heartbeat
|
||||
(dispatcher-approvals-process)
|
||||
(if action (dispatcher-check action context) action))
|
||||
(otherwise
|
||||
(if action (dispatcher-check action context) action)))))
|
||||
|
||||
(defskill :passepartout-security-dispatcher
|
||||
:priority 150
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic #'dispatcher-gate)
|
||||
13
lisp/security-permissions.lisp
Normal file
13
lisp/security-permissions.lisp
Normal file
@@ -0,0 +1,13 @@
|
||||
(defvar *permission-table* (make-hash-table :test 'equal))
|
||||
|
||||
(defun permission-set (tool-name level)
|
||||
"Sets the permission level for a tool."
|
||||
(setf (gethash (string-downcase (string tool-name)) *permission-table*) level))
|
||||
|
||||
(defun permission-get (tool-name)
|
||||
"Retrieves the permission level for a tool. Defaults to :ask."
|
||||
(gethash (string-downcase (string tool-name)) *permission-table* :ask))
|
||||
|
||||
(defskill :passepartout-security-permissions
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
17
lisp/security-policy.lisp
Normal file
17
lisp/security-policy.lisp
Normal file
@@ -0,0 +1,17 @@
|
||||
(defun policy-compliance-check (action context)
|
||||
"Enforces constitutional invariants on proposed actions."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (proto-get action :payload))
|
||||
(explanation (proto-get payload :explanation)))
|
||||
(if (and explanation (stringp explanation) (> (length explanation) 10))
|
||||
action
|
||||
(progn
|
||||
(log-message "POLICY VIOLATION: Action lacks sufficient explanation.")
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning."))))))
|
||||
|
||||
(defskill :passepartout-security-policy
|
||||
:priority 500
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic #'policy-compliance-check)
|
||||
13
lisp/security-validator.lisp
Normal file
13
lisp/security-validator.lisp
Normal file
@@ -0,0 +1,13 @@
|
||||
(defun validator-protocol-check (msg)
|
||||
"Enforces structural schema compliance on protocol messages."
|
||||
(validate-communication-protocol-schema msg))
|
||||
|
||||
(defskill :passepartout-security-validator
|
||||
:priority 95
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(handler-case
|
||||
(progn (validator-protocol-check action) action)
|
||||
(error (c)
|
||||
(list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c)))))))
|
||||
33
lisp/security-vault.lisp
Normal file
33
lisp/security-vault.lisp
Normal file
@@ -0,0 +1,33 @@
|
||||
(defvar *vault-memory* (make-hash-table :test 'equal)
|
||||
"In-memory cache of sensitive credentials.")
|
||||
|
||||
(defun vault-get (provider &key (type :api-key))
|
||||
"Retrieves a credential from the vault or environment."
|
||||
(let* ((key (format nil "~a-~a" provider type))
|
||||
(val (gethash key *vault-memory*)))
|
||||
(if val
|
||||
val
|
||||
(let ((env-var (case provider
|
||||
(:gemini "GEMINI_API_KEY")
|
||||
(:openai "OPENAI_API_KEY")
|
||||
(:anthropic "ANTHROPIC_API_KEY")
|
||||
(:openrouter "OPENROUTER_API_KEY")
|
||||
(otherwise nil))))
|
||||
(when env-var (uiop:getenv env-var))))))
|
||||
|
||||
(defun vault-set (provider secret &key (type :api-key))
|
||||
"Stores a secret in the vault."
|
||||
(let ((key (format nil "~a-~a" provider type)))
|
||||
(setf (gethash key *vault-memory*) secret)))
|
||||
|
||||
(defun vault-get-secret (provider)
|
||||
"Retrieves a stored secret or token for a gateway provider."
|
||||
(vault-get provider :type :secret))
|
||||
|
||||
(defun vault-set-secret (provider secret)
|
||||
"Stores a secret or token for a gateway provider."
|
||||
(vault-set provider secret :type :secret))
|
||||
|
||||
(defskill :passepartout-security-vault
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
27
lisp/system-actuator-shell.lisp
Normal file
27
lisp/system-actuator-shell.lisp
Normal file
@@ -0,0 +1,27 @@
|
||||
(defun actuator-shell-execute (action context)
|
||||
"Executes a bash command with timeout (via timeout(1)) and output limit."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(cmd (getf payload :cmd))
|
||||
(timeout-sym (find-symbol "*BOUNCER-SHELL-TIMEOUT*" :passepartout))
|
||||
(timeout (or (getf payload :timeout) (if timeout-sym (symbol-value timeout-sym) 30)))
|
||||
(max-sym (find-symbol "*BOUNCER-SHELL-MAX-OUTPUT*" :passepartout))
|
||||
(max-output (or (getf payload :max-output) (if max-sym (symbol-value max-sym) 100000)))
|
||||
(wrapped-cmd (format nil "timeout ~a bash -c ~s" timeout cmd)))
|
||||
(log-message "ACT [Shell]: ~a (timeout: ~as)" cmd timeout)
|
||||
(multiple-value-bind (out err code)
|
||||
(uiop:run-program (list "bash" "-c" wrapped-cmd)
|
||||
:output :string :error-output :string
|
||||
:ignore-error-status t)
|
||||
(cond
|
||||
((= code 124) (format nil "ERROR: Command timed out after ~a seconds" timeout))
|
||||
((> (length out) max-output)
|
||||
(format nil "~a~%... (output truncated to ~a chars)" (subseq out 0 max-output) max-output))
|
||||
((= code 0) out)
|
||||
(t (format nil "ERROR [~a]: ~a" code err))))))
|
||||
|
||||
(register-actuator :shell #'actuator-shell-execute)
|
||||
|
||||
(defskill :passepartout-system-actuator-shell
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
236
lisp/system-archivist.lisp
Normal file
236
lisp/system-archivist.lisp
Normal file
@@ -0,0 +1,236 @@
|
||||
(defvar *archivist-last-scribe* 0
|
||||
"Universal time of the last Scribe distillation run.")
|
||||
|
||||
(defvar *archivist-last-gardener* 0
|
||||
"Universal time of the last Gardener scan run.")
|
||||
|
||||
(defvar *archivist-gardener-interval* 86400
|
||||
"Seconds between Gardener scans. Default: 24 hours.")
|
||||
|
||||
(defun archivist-scribe-distill ()
|
||||
"Distills daily log entries into atomic notes. Reads the Memex daily/
|
||||
directory for log files modified since the last run, extracts headlines
|
||||
as potential note seeds, and creates atomic note files in notes/ with
|
||||
backlinks to the source daily entry."
|
||||
(let* ((memex-dir (or (uiop:getenv "MEMEX_DIR")
|
||||
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
|
||||
(daily-dir (merge-pathnames "daily/" memex-dir))
|
||||
(notes-dir (merge-pathnames "notes/" memex-dir))
|
||||
(now (get-universal-time))
|
||||
(notes-created 0))
|
||||
(unless (uiop:directory-exists-p daily-dir)
|
||||
(log-message "ARCHIVIST: Daily directory not found: ~a" daily-dir)
|
||||
(return-from archivist-scribe-distill nil))
|
||||
(ensure-directories-exist notes-dir)
|
||||
(handler-case
|
||||
(let ((daily-files (uiop:directory-files daily-dir "*.org")))
|
||||
(dolist (file daily-files)
|
||||
(let* ((filepath (namestring file))
|
||||
(file-mtime (ignore-errors (file-write-date filepath))))
|
||||
(when (and file-mtime (> file-mtime *archivist-last-scribe*))
|
||||
;; Extract headlines from daily log
|
||||
(let* ((content (handler-case (uiop:read-file-string filepath)
|
||||
(error () nil)))
|
||||
(headlines (when content
|
||||
(archivist-extract-headlines content))))
|
||||
(dolist (hl headlines)
|
||||
(when (archivist-create-note hl notes-dir filepath)
|
||||
(incf notes-created))))))))
|
||||
(error (c)
|
||||
(log-message "ARCHIVIST: Scribe error: ~a" c)))
|
||||
(setf *archivist-last-scribe* now)
|
||||
(when (> notes-created 0)
|
||||
(log-message "ARCHIVIST: Scribe created ~d atomic notes" notes-created))
|
||||
notes-created))
|
||||
|
||||
(defun archivist-extract-headlines (content)
|
||||
"Extracts first-level headlines and their content from Org text.
|
||||
Returns a list of plists: (:title <str> :content <str> :tags <list>)."
|
||||
(let ((lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(results nil)
|
||||
(current-title nil)
|
||||
(current-lines nil)
|
||||
(current-tags nil)
|
||||
(in-properties nil))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space) line)))
|
||||
(when (string= trimmed ":PROPERTIES:")
|
||||
(setf in-properties t))
|
||||
(when (string= trimmed ":END:")
|
||||
(setf in-properties nil))
|
||||
(when (and in-properties (uiop:string-prefix-p ":TAGS:" trimmed))
|
||||
(setf current-tags
|
||||
(mapcar (lambda (t) (string-trim '(#\Space) t))
|
||||
(uiop:split-string (string-trim '(#\Space) (subseq trimmed 6))
|
||||
:separator '(#\space #\tab)))))
|
||||
(cond
|
||||
;; First-level headline
|
||||
((and (uiop:string-prefix-p "* " trimmed)
|
||||
(not (uiop:string-prefix-p "**" trimmed)))
|
||||
;; Save previous
|
||||
(when current-title
|
||||
(push (list :title current-title
|
||||
:content (format nil "~{~a~^~%~}" (nreverse current-lines))
|
||||
:tags current-tags)
|
||||
results))
|
||||
(setf current-title (string-trim '(#\* #\Space) trimmed)
|
||||
current-lines nil
|
||||
current-tags nil
|
||||
in-properties nil))
|
||||
;; Content lines under current headline
|
||||
(current-title
|
||||
(unless (or (uiop:string-prefix-p "*" trimmed)
|
||||
(string= trimmed ":PROPERTIES:")
|
||||
(string= trimmed ":END:"))
|
||||
(push line current-lines))))))
|
||||
;; Save last headline
|
||||
(when current-title
|
||||
(push (list :title current-title
|
||||
:content (format nil "~{~a~^~%~}" (nreverse current-lines))
|
||||
:tags current-tags)
|
||||
results))
|
||||
(nreverse results)))
|
||||
|
||||
(defun archivist-headline-to-filename (title)
|
||||
"Converts a headline title to a valid atomic note filename.
|
||||
Replaces spaces and special chars with underscores, downcases."
|
||||
(let* ((clean (cl-ppcre:regex-replace-all "[^a-zA-Z0-9 ]" title ""))
|
||||
(underscored (cl-ppcre:regex-replace-all "\\s+" clean "_"))
|
||||
(lowered (string-downcase underscored)))
|
||||
(if (> (length lowered) 100)
|
||||
(subseq lowered 0 100)
|
||||
lowered)))
|
||||
|
||||
(defun archivist-create-note (headline notes-dir source-filepath)
|
||||
"Creates an atomic note from a headline plist in the notes/ directory.
|
||||
Headline is a plist (:title <str> :content <str> :tags <list>).
|
||||
Returns T if note was created, nil if it already exists."
|
||||
(let* ((title (getf headline :title))
|
||||
(content (or (getf headline :content) ""))
|
||||
(tags (getf headline :tags))
|
||||
(filename (archivist-headline-to-filename title))
|
||||
(filepath (merge-pathnames (format nil "~a.org" filename) notes-dir))
|
||||
(source-basename (enough-namestring source-filepath
|
||||
(merge-pathnames "" notes-dir))))
|
||||
(when (uiop:file-exists-p filepath)
|
||||
(return-from archivist-create-note nil))
|
||||
(handler-case
|
||||
(uiop:with-output-file (s filepath :if-exists :nil)
|
||||
(format s "#+TITLE: ~a~%" title)
|
||||
(format s "#+FILETAGS: :atomic:note:~:[~;~{~a~^:~}~]~%" tags tags)
|
||||
(format s "~%* ~a~%" title)
|
||||
(format s ":PROPERTIES:~%")
|
||||
(format s ":CREATED: ~a~%" (org-id-generate))
|
||||
(format s ":SOURCE: ~a~%" source-basename)
|
||||
(format s ":END:~%")
|
||||
(format s "~%~a~%" content)
|
||||
(format s "~%* Backlinks~%")
|
||||
(format s "- Source: [[file:~a][~a]]~%" source-basename
|
||||
(file-namestring source-filepath)))
|
||||
(log-message "ARCHIVIST: Created note ~a" (namestring filepath))
|
||||
t)
|
||||
(error (c)
|
||||
(log-message "ARCHIVIST: Failed to create note ~a: ~a" filepath c)
|
||||
nil)))
|
||||
|
||||
(defun archivist-gardener-scan ()
|
||||
"Scans the Memex for broken file links and orphaned memory objects.
|
||||
Broken links are =[[file:...]]= references whose target file does not exist.
|
||||
Orphaned objects are =memory-object= entries whose =:parent-id= references
|
||||
a deleted object. Returns a plist (:broken-links <count> :orphans <count>)."
|
||||
(let* ((memex-dir (or (uiop:getenv "MEMEX_DIR")
|
||||
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
|
||||
(org-files (archivist-find-org-files memex-dir))
|
||||
(broken-links 0)
|
||||
(orphans 0))
|
||||
;; Scan for broken links
|
||||
(dolist (file org-files)
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string file))
|
||||
(links (archivist-extract-file-links content)))
|
||||
(dolist (link links)
|
||||
(let ((target (merge-pathnames link (make-pathname :directory
|
||||
(pathname-directory file)))))
|
||||
(unless (uiop:file-exists-p target)
|
||||
(log-message "ARCHIVIST: Broken link in ~a -> ~a"
|
||||
(enough-namestring file memex-dir) link)
|
||||
(incf broken-links)))))
|
||||
(error ()
|
||||
(log-message "ARCHIVIST: Could not read ~a" file))))
|
||||
;; Scan for orphaned memory objects
|
||||
(handler-case
|
||||
(let ((deleted-ids (make-hash-table :test 'equal)))
|
||||
;; In practice, we check if parent-id points to a non-existent object
|
||||
(maphash (lambda (id obj)
|
||||
(declare (ignore obj))
|
||||
(setf (gethash id deleted-ids) t))
|
||||
(if (boundp '*memory-store*)
|
||||
(symbol-value '*memory-store*)
|
||||
(make-hash-table :test 'equal)))
|
||||
(let ((store (if (boundp '*memory-store*)
|
||||
(symbol-value '*memory-store*)
|
||||
(make-hash-table :test 'equal))))
|
||||
(maphash (lambda (id obj)
|
||||
(let ((parent (memory-object-parent-id obj)))
|
||||
(when (and parent (not (gethash parent store)))
|
||||
(log-message "ARCHIVIST: Orphaned object ~a (parent ~a not found)"
|
||||
id parent)
|
||||
(incf orphans))))
|
||||
store)))
|
||||
(error ()
|
||||
(log-message "ARCHIVIST: Memory store not available for orphan scan")))
|
||||
(setf *archivist-last-gardener* (get-universal-time))
|
||||
(list :broken-links broken-links :orphans orphans)))
|
||||
|
||||
(defun archivist-find-org-files (memex-dir)
|
||||
"Recursively finds all .org files under memex-dir, up to 3 levels deep."
|
||||
(let ((files nil))
|
||||
(labels ((walk (dir depth)
|
||||
(when (and (uiop:directory-exists-p dir) (< depth 3))
|
||||
(handler-case
|
||||
(dolist (entry (uiop:subdirectories dir))
|
||||
(walk entry (1+ depth)))
|
||||
(error ()))
|
||||
(handler-case
|
||||
(dolist (file (uiop:directory-files dir "*.org"))
|
||||
(push (namestring file) files))
|
||||
(error ())))))
|
||||
(walk memex-dir 0))
|
||||
files))
|
||||
|
||||
(defun archivist-extract-file-links (content)
|
||||
"Extracts all =[[file:...]]= link targets from Org content.
|
||||
Returns a list of link target strings."
|
||||
(let ((links nil))
|
||||
(cl-ppcre:do-register-groups (target)
|
||||
("\\[\\[file:([^\\]]+)\\]\\[" content)
|
||||
(unless (search "::" target) ;; skip internal anchors
|
||||
(pushnew target links :test #'string=)))
|
||||
;; Also handle bare [[file:target]] links
|
||||
(cl-ppcre:do-register-groups (target)
|
||||
("\\[\\[file:([^\\]]+)\\]\\]" content)
|
||||
(unless (search "::" target)
|
||||
(pushnew target links :test #'string=)))
|
||||
links))
|
||||
|
||||
(defun archivist-run (context)
|
||||
"Runs the archivist maintenance cycle. Checks Scribe and Gardener schedules
|
||||
and dispatches as needed. Called by the deterministic gate."
|
||||
(declare (ignore context))
|
||||
(let ((now (get-universal-time)))
|
||||
;; Scribe runs every 6 hours (21600 seconds)
|
||||
(when (>= (- now *archivist-last-scribe*) 21600)
|
||||
(ignore-errors (archivist-scribe-distill)))
|
||||
;; Gardener runs every 24 hours
|
||||
(when (>= (- now *archivist-last-gardener*) *archivist-gardener-interval*)
|
||||
(ignore-errors
|
||||
(let ((result (archivist-gardener-scan)))
|
||||
(when (> (getf result :broken-links) 0)
|
||||
(log-message "ARCHIVIST: Gardener found ~d broken links, ~d orphans"
|
||||
(getf result :broken-links) (getf result :orphans)))))))
|
||||
nil)
|
||||
|
||||
(defskill :passepartout-system-archivist
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic #'archivist-run)
|
||||
243
lisp/system-config.lisp
Normal file
243
lisp/system-config.lisp
Normal file
@@ -0,0 +1,243 @@
|
||||
(defun config-directory ()
|
||||
"Returns the absolute path to the opencortex config directory."
|
||||
(let ((xdg (uiop:getenv "OC_CONFIG_DIR")))
|
||||
(if xdg xdg (namestring (merge-pathnames ".config/passepartout/" (user-homedir-pathname))))))
|
||||
|
||||
(defun config-file-path ()
|
||||
"Returns the path to the .env configuration file."
|
||||
(merge-pathnames ".env" (config-directory)))
|
||||
|
||||
(defun config-directory-ensure ()
|
||||
"Creates the configuration directory if it does not exist."
|
||||
(ensure-directories-exist (config-directory)))
|
||||
|
||||
(defun config-read ()
|
||||
"Reads the .env config file and returns an alist of KEY=VALUE pairs."
|
||||
(let ((config-file (config-file-path)))
|
||||
(when (uiop:file-exists-p config-file)
|
||||
(let ((lines (uiop:read-file-lines config-file))
|
||||
(result nil))
|
||||
(dolist (line lines)
|
||||
(when (and line (> (length line) 0)
|
||||
(not (uiop:string-prefix-p "#" line)))
|
||||
(let ((eq-pos (position #\= line)))
|
||||
(when eq-pos
|
||||
(let ((key (string-trim " " (subseq line 0 eq-pos)))
|
||||
(value (string-trim " " (subseq line (1+ eq-pos)))))
|
||||
(push (cons key value) result))))))
|
||||
(nreverse result)))))
|
||||
|
||||
(defun config-write (config-alist)
|
||||
"Writes the config alist to the .env file."
|
||||
(config-directory-ensure)
|
||||
(let ((config-file (config-file-path)))
|
||||
(with-open-file (stream config-file :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(format stream "# Passepartout Configuration~%")
|
||||
(format stream "# Generated by opencortex setup~%~%")
|
||||
(dolist (pair config-alist)
|
||||
(format stream "~a=~a~%" (car pair) (cdr pair))))))
|
||||
|
||||
(defun config-get (key)
|
||||
"Gets a config value by key."
|
||||
(let ((config (config-read)))
|
||||
(cdr (assoc key config :test #'string=))))
|
||||
|
||||
(defun config-set (key value)
|
||||
"Sets a config value and saves to file."
|
||||
(let ((config (config-read))
|
||||
(pair (cons key value)))
|
||||
(let ((existing (assoc key config :test #'string=)))
|
||||
(if existing
|
||||
(setf (cdr existing) value)
|
||||
(push pair config))
|
||||
(config-write config))))
|
||||
|
||||
(defun prompt (prompt-text)
|
||||
"Simple prompt that returns user input as a string."
|
||||
(format t "~a" prompt-text)
|
||||
(finish-output)
|
||||
(read-line))
|
||||
|
||||
(defun prompt-yes-no (prompt-text)
|
||||
"Prompts yes/no question. Returns T for yes, nil for no."
|
||||
(let ((response (prompt (format nil "~a [Y/n]: " prompt-text))))
|
||||
(or (string= response "")
|
||||
(string-equal response "Y")
|
||||
(string-equal response "y")
|
||||
(string-equal response "yes"))))
|
||||
|
||||
(defun prompt-choice (prompt-text options)
|
||||
"Prompts user to choose from a list of options. Returns the chosen option or nil."
|
||||
(format t "~a~%" prompt-text)
|
||||
(let ((i 1))
|
||||
(dolist (opt options)
|
||||
(format t " ~a) ~a~%" i opt)
|
||||
(incf i)))
|
||||
(let ((response (prompt "Choice")))
|
||||
(let ((num (ignore-errors (parse-integer response))))
|
||||
(when (and num (<= 1 num) (>= (length options) num))
|
||||
(nth (1- num) options)))))
|
||||
|
||||
(defparameter *available-providers*
|
||||
'(("OpenAI" . "OPENAI_API_KEY")
|
||||
("Anthropic" . "ANTHROPIC_API_KEY")
|
||||
("OpenRouter" . "OPENROUTER_API_KEY")
|
||||
("Groq" . "GROQ_API_KEY")
|
||||
("Gemini" . "GEMINI_API_KEY")
|
||||
("Ollama (local)" . "OLLAMA_URL")))
|
||||
|
||||
(defun setup-llm-providers ()
|
||||
"Interactive wizard for configuring LLM providers."
|
||||
(format t "~%~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " LLM Provider Configuration~%")
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(let ((current-providers (loop for (name . key) in *available-providers*
|
||||
when (config-get key)
|
||||
collect name)))
|
||||
(when current-providers
|
||||
(format t "Current providers: ~{~a~^, ~}~%~%" current-providers))
|
||||
|
||||
(format t "Available providers:~%")
|
||||
(dolist (p *available-providers*)
|
||||
(format t " - ~a~%" (car p)))
|
||||
(format t "~%")
|
||||
|
||||
(when (prompt-yes-no "Configure a new provider?")
|
||||
(let ((chosen (prompt-choice "Select provider:" (mapcar #'car *available-providers*))))
|
||||
(when chosen
|
||||
(let ((env-key (cdr (assoc chosen *available-providers* :test #'string=))))
|
||||
(if (string= chosen "Ollama (local)")
|
||||
(progn
|
||||
(format t "Enter Ollama URL (e.g., http://localhost:11434): ")
|
||||
(let ((url (read-line)))
|
||||
(config-set env-key url)
|
||||
(format t "✓ Ollama configured at ~a~%" url)))
|
||||
(progn
|
||||
(format t "Enter API key for ~a: " chosen)
|
||||
(let ((key (read-line)))
|
||||
(config-set env-key key)
|
||||
(format t "✓ ~a API key saved~%" chosen)))))))))
|
||||
|
||||
(format t "~%"))
|
||||
|
||||
(defun setup-add-provider ()
|
||||
"Entry point for adding a single provider (called from CLI)."
|
||||
(setup-llm-providers))
|
||||
|
||||
(defun setup-gateways ()
|
||||
"Interactive wizard for configuring external gateways."
|
||||
(format t "~%~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " Gateway Configuration~%")
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(format t "Available gateways:~%")
|
||||
(format t " - Slack (https://api.slack.com/)~%")
|
||||
(format t " - Discord (https://discord.com/developers/)~%")
|
||||
(format t "~%")
|
||||
|
||||
(when (prompt-yes-no "Configure a gateway?")
|
||||
(let ((chosen (prompt-choice "Select platform:" '("Slack" "Discord"))))
|
||||
(when chosen
|
||||
(let ((token (prompt (format nil "Enter ~a bot token: " chosen))))
|
||||
(if (string= chosen "Slack")
|
||||
(config-set "SLACK_TOKEN" token)
|
||||
(config-set "DISCORD_TOKEN" token))
|
||||
(format t "✓ ~a gateway configured~%" chosen)))))
|
||||
|
||||
(format t "~%"))
|
||||
|
||||
(defun setup-skills ()
|
||||
"Interactive wizard for enabling/disabling skills."
|
||||
(format t "~%~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " Skill Management~%")
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(format t "Note: Skill management is not yet implemented.~%")
|
||||
(format t "Skills are automatically loaded from ~a~%" (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") "~/.local/share/passepartout"))
|
||||
(format t "~%"))
|
||||
|
||||
(defun setup-memory ()
|
||||
"Interactive wizard for memory settings."
|
||||
(format t "~%~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " Memory Settings~%")
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(let ((auto-save (prompt "Auto-save interval in seconds [300]:")))
|
||||
(when (and auto-save (> (length auto-save) 0))
|
||||
(config-set "MEMORY_AUTO_SAVE_INTERVAL" auto-save)))
|
||||
|
||||
(let ((history (prompt "History retention in lines [1000]:")))
|
||||
(when (and history (> (length history) 0))
|
||||
(config-set "MEMORY_HISTORY_RETENTION" history)))
|
||||
|
||||
(format t "✓ Memory settings saved~%")
|
||||
(format t "~%"))
|
||||
|
||||
(defun setup-network ()
|
||||
"Interactive wizard for network settings."
|
||||
(format t "~%~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " Network Settings~%")
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(let ((timeout (prompt "Request timeout in seconds [30]:")))
|
||||
(when (and timeout (> (length timeout) 0))
|
||||
(config-set "REQUEST_TIMEOUT" timeout)))
|
||||
|
||||
(let ((proxy (prompt "Proxy URL (leave empty for none) []:")))
|
||||
(when (and proxy (> (length proxy) 0))
|
||||
(config-set "HTTP_PROXY" proxy)))
|
||||
|
||||
(format t "✓ Network settings saved~%")
|
||||
(format t "~%"))
|
||||
|
||||
(defun setup-wizard-run ()
|
||||
"Main entry point for the interactive setup wizard."
|
||||
(format t "~%~%")
|
||||
(format t "╔═══════════════════════════════════════════════════╗~%")
|
||||
(format t "║ Passepartout Setup Wizard ║~%")
|
||||
(format t "╚═══════════════════════════════════════════════════╝~%")
|
||||
(format t "~%")
|
||||
(format t "This wizard will help you configure:~%")
|
||||
(format t " 1. LLM Providers (OpenAI, Anthropic, etc.)~%")
|
||||
(format t " 2. Gateway Links (Slack, Discord)~%")
|
||||
(format t " 3. Memory Settings~%")
|
||||
(format t " 4. Network Settings~%")
|
||||
(format t "~%")
|
||||
|
||||
(config-directory-ensure)
|
||||
|
||||
;; Step 1: LLM Providers
|
||||
(when (prompt-yes-no "Configure LLM providers?")
|
||||
(setup-llm-providers))
|
||||
|
||||
;; Step 2: Gateways
|
||||
(when (prompt-yes-no "Configure gateways?")
|
||||
(setup-gateways))
|
||||
|
||||
;; Step 3: Memory
|
||||
(when (prompt-yes-no "Configure memory settings?")
|
||||
(setup-memory))
|
||||
|
||||
;; Step 4: Network
|
||||
(when (prompt-yes-no "Configure network settings?")
|
||||
(setup-network))
|
||||
|
||||
;; Summary
|
||||
(format t "==================================================~%")
|
||||
(format t " Setup Complete!~%")
|
||||
(format t "==================================================~%")
|
||||
(format t "~%")
|
||||
(format t "Configuration saved to: ~a~%" (config-file-path))
|
||||
(format t "~%")
|
||||
(format t "To verify your setup, run: passepartout doctor~%")
|
||||
(format t "~%"))
|
||||
|
||||
(defskill :passepartout-system-config
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
176
lisp/system-diagnostics.lisp
Normal file
176
lisp/system-diagnostics.lisp
Normal file
@@ -0,0 +1,176 @@
|
||||
(defvar *diagnostics-binaries* '("sbcl" "emacs" "git" "socat" "nc")
|
||||
"List of external binaries required for full system operation.")
|
||||
|
||||
(defvar *diagnostics-package-map*
|
||||
'(("sbcl" . "sbcl")
|
||||
("emacs" . "emacs")
|
||||
("git" . "git")
|
||||
("socat" . "socat")
|
||||
("nc" . "netcat-openbsd")
|
||||
("curl" . "curl")
|
||||
("rlwrap" . "rlwrap"))
|
||||
"Map binary names to apt package names.")
|
||||
|
||||
(defvar *doctor-missing-deps* nil
|
||||
"List of missing dependencies populated by diagnostics-dependencies-check.")
|
||||
|
||||
(defvar *doctor-auto-install* t
|
||||
"When T, doctor will attempt to install missing dependencies automatically.")
|
||||
|
||||
(defun diagnostics-dependencies-check ()
|
||||
"Verifies that required external binaries are available in the PATH via shell probe."
|
||||
(setf *doctor-missing-deps* nil)
|
||||
(let ((all-ok t))
|
||||
(format t "DOCTOR: Checking system dependencies...~%")
|
||||
(dolist (dep *diagnostics-binaries*)
|
||||
(let ((path (ignore-errors
|
||||
(uiop:run-program (list "which" dep)
|
||||
:output :string :ignore-error-status t))))
|
||||
(if (and path (> (length path) 0))
|
||||
(format t " [OK] Found ~a~%" dep)
|
||||
(progn
|
||||
(format t " [FAIL] Missing binary: ~a~%" dep)
|
||||
(push dep *doctor-missing-deps*)
|
||||
(setf all-ok nil)))))
|
||||
(when (and all-ok (null *doctor-missing-deps*))
|
||||
(format t "DOCTOR: All dependencies satisfied.~%"))
|
||||
all-ok))
|
||||
|
||||
(defun diagnostics-dependencies-install ()
|
||||
"Attempts to install missing system dependencies via apt."
|
||||
(when (null *doctor-missing-deps*)
|
||||
(format t "DOCTOR: No missing dependencies to install.~%")
|
||||
(return-from diagnostics-dependencies-install t))
|
||||
|
||||
(format t "DOCTOR: Attempting to install ~a missing dependencies...~%" (length *doctor-missing-deps*))
|
||||
|
||||
(let ((packages (remove-duplicates
|
||||
(mapcar (lambda (dep)
|
||||
(or (cdr (assoc dep *diagnostics-package-map* :test #'string=))
|
||||
dep))
|
||||
*doctor-missing-deps*)
|
||||
:test #'string=)))
|
||||
(format t "DOCTOR: Packages to install: ~a~%" packages)
|
||||
|
||||
(let ((cmd (format nil "apt-get install -y ~{~a~^ ~}" packages)))
|
||||
(format t "DOCTOR: Running: ~a~%" cmd)
|
||||
(handler-case
|
||||
(let ((output (uiop:run-program cmd
|
||||
:output :string
|
||||
:error-output :string
|
||||
:external-format :utf-8)))
|
||||
(if (zerop (uiop:run-program (format nil "which ~a" (car *doctor-missing-deps*))
|
||||
:ignore-error-status t))
|
||||
(progn
|
||||
(format t "DOCTOR: Dependencies installed successfully.~%")
|
||||
(setf *doctor-missing-deps* nil)
|
||||
t)
|
||||
(progn
|
||||
(format t "DOCTOR: Installation failed. Output: ~a~%" output)
|
||||
nil)))
|
||||
(error (c)
|
||||
(format t "DOCTOR: Installation error: ~a~%" c)
|
||||
nil)))))
|
||||
|
||||
(defun diagnostics-env-check ()
|
||||
"Validates XDG directories and environment configuration."
|
||||
(format t "DOCTOR: Checking XDG environment...~%")
|
||||
(let ((all-ok t)
|
||||
(config-dir (uiop:getenv "PASSEPARTOUT_CONFIG_DIR"))
|
||||
(data-dir (uiop:getenv "PASSEPARTOUT_DATA_DIR"))
|
||||
(state-dir (uiop:getenv "PASSEPARTOUT_STATE_DIR"))
|
||||
(memex-dir (uiop:getenv "MEMEX_DIR")))
|
||||
|
||||
(flet ((check-dir (name path critical)
|
||||
(if (and path (> (length path) 0))
|
||||
(if (uiop:directory-exists-p path)
|
||||
(format t " [OK] ~a: ~a~%" name path)
|
||||
(progn
|
||||
(format t " [FAIL] ~a directory missing: ~a~%" name path)
|
||||
(when critical (setf all-ok nil))))
|
||||
(progn
|
||||
(format t " [FAIL] ~a variable not set.~%" name)
|
||||
(when critical (setf all-ok nil))))))
|
||||
|
||||
(check-dir "Config (PASSEPARTOUT_CONFIG_DIR)" config-dir t)
|
||||
(check-dir "Data (PASSEPARTOUT_DATA_DIR)" data-dir t)
|
||||
(check-dir "State (PASSEPARTOUT_STATE_DIR)" state-dir t)
|
||||
(check-dir "Memex (MEMEX_DIR)" memex-dir t))
|
||||
all-ok))
|
||||
|
||||
(defun diagnostics-llm-check ()
|
||||
"Tests connectivity to LLM providers. Returns T if at least one provider is configured."
|
||||
(format t "DOCTOR: Checking LLM connectivity...~%")
|
||||
(let ((providers '((:openrouter . "OPENROUTER_API_KEY")
|
||||
(:anthropic . "ANTHROPIC_API_KEY")
|
||||
(:openai . "OPENAI_API_KEY")
|
||||
(:groq . "GROQ_API_KEY")
|
||||
(:gemini . "GEMINI_API_KEY")
|
||||
(:deepseek . "DEEPSEEK_API_KEY")
|
||||
(:nvidia . "NVIDIA_API_KEY")
|
||||
(:ollama . "OLLAMA_URL")))
|
||||
(configured nil))
|
||||
(dolist (p providers)
|
||||
(let ((env-val (uiop:getenv (cdr p))))
|
||||
(cond
|
||||
((and env-val (> (length env-val) 0))
|
||||
(format t " [OK] ~a configured~%" (car p))
|
||||
(setf configured t))
|
||||
((eq (car p) :ollama)
|
||||
(let ((ollama-check (ignore-errors
|
||||
(uiop:run-program '("curl" "-s" "http://localhost:11434/api/tags")
|
||||
:output :string :ignore-error-status t))))
|
||||
(when (and ollama-check (search "\"models\"" ollama-check))
|
||||
(format t " [OK] Ollama local model server detected~%")
|
||||
(setf configured t)))))))
|
||||
(if configured
|
||||
(progn
|
||||
(format t " [OK] LLM provider(s) available~%")
|
||||
t)
|
||||
(progn
|
||||
(format t " [WARN] No LLM provider configured.~%")
|
||||
(format t " Run 'passepartout configure' to configure a provider.~%")
|
||||
t))))
|
||||
|
||||
(defun diagnostics-run-all (&key (auto-install t))
|
||||
"Executes the full diagnostic suite and returns T if system is healthy."
|
||||
(format t "==================================================~%")
|
||||
(format t " PASSEPARTOUT DOCTOR: Commencing Health Check~%")
|
||||
(format t "==================================================~%")
|
||||
(let ((dep-ok (diagnostics-dependencies-check)))
|
||||
(when (and (not dep-ok) auto-install *doctor-auto-install*)
|
||||
(format t "DOCTOR: Attempting automatic installation...~%")
|
||||
(setf dep-ok (diagnostics-dependencies-install))
|
||||
(when dep-ok
|
||||
(setf dep-ok (diagnostics-dependencies-check))))
|
||||
(let ((env-ok (diagnostics-env-check))
|
||||
(llm-ok (diagnostics-llm-check)))
|
||||
(format t "==================================================~%")
|
||||
(if (and dep-ok env-ok)
|
||||
(progn
|
||||
(format t " ✓ SYSTEM HEALTHY: Ready for ignition.~%")
|
||||
t) ;; Explicitly return T
|
||||
(progn
|
||||
(format t "==================================================~%")
|
||||
(format t " ISSUES FOUND:~%")
|
||||
(when (not dep-ok)
|
||||
(format t " - Missing system dependencies~%"))
|
||||
(when (not llm-ok)
|
||||
(format t " - No LLM provider configured~%"))
|
||||
(format t "~%")
|
||||
(format t " RECOMMENDED ACTIONS:~%")
|
||||
(format t " 1. Run 'passepartout configure' to configure everything~%")
|
||||
(format t " 2. Or run 'passepartout doctor --fix' for auto-repair~%")
|
||||
(format t "==================================================~%")
|
||||
nil))))) ;; Return nil when issues found
|
||||
|
||||
(defun diagnostics-main ()
|
||||
"Entry point for the 'doctor' CLI command."
|
||||
(if (diagnostics-run-all)
|
||||
(uiop:quit 0)
|
||||
(uiop:quit 1)))
|
||||
|
||||
(defskill :passepartout-system-diagnostics
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
||||
205
lisp/system-event-orchestrator.lisp
Normal file
205
lisp/system-event-orchestrator.lisp
Normal file
@@ -0,0 +1,205 @@
|
||||
(defpackage :passepartout.system-event-orchestrator
|
||||
(:use :cl :passepartout)
|
||||
(:export
|
||||
:orchestrator-register-hook
|
||||
:orchestrator-register-cron
|
||||
:orchestrator-classify
|
||||
:orchestrator-on-heartbeat
|
||||
:orchestrator-bootstrap
|
||||
:orchestrator-dispatch
|
||||
:default-classifier
|
||||
:parse-org-repeat
|
||||
:*hook-registry*
|
||||
:*cron-registry*
|
||||
:*tier-classifier*))
|
||||
|
||||
(in-package :passepartout.system-event-orchestrator)
|
||||
|
||||
(defvar *hook-registry* (make-hash-table :test 'equal)
|
||||
"Maps hook property string → list of gate function symbols.")
|
||||
|
||||
(defvar *cron-registry* (make-hash-table :test 'equal)
|
||||
"Maps job name string → plist (:next-run :expression :repeat :action :tier).")
|
||||
|
||||
(defvar *tier-classifier* nil
|
||||
"Optional function (context) → :reflex | :cognition | :reasoning.")
|
||||
|
||||
(defun default-classifier (context)
|
||||
"Rule-based tier classification.
|
||||
:reflex — file/shell operations, deterministic checks
|
||||
:cognition — text processing, summarization, simple Q&A
|
||||
:reasoning — planning, analysis, multi-step decisions"
|
||||
(let* ((text (or (getf context :text) ""))
|
||||
(lower (string-downcase text)))
|
||||
(cond
|
||||
((or (search "rm " lower)
|
||||
(search "write-file" lower)
|
||||
(search "shell" lower)
|
||||
(search "verify-" lower))
|
||||
:reflex)
|
||||
((or (search "summarize" lower)
|
||||
(search "list" lower)
|
||||
(search "find " lower)
|
||||
(search "what is" lower)
|
||||
(search "search" lower))
|
||||
:cognition)
|
||||
(t :reasoning))))
|
||||
|
||||
(defun parse-org-repeat (timestamp-string)
|
||||
(let* ((cleaned (string-trim '(#\< #\> #\Newline #\Tab) timestamp-string))
|
||||
(parts (uiop:split-string cleaned :separator '(#\space)))
|
||||
(repeat-part (ignore-errors (car (last parts)))))
|
||||
(when (and repeat-part (uiop:string-prefix-p "+" repeat-part))
|
||||
(let* ((rest (subseq repeat-part 1))
|
||||
(num-end (position-if (lambda (c) (not (digit-char-p c))) rest))
|
||||
(num (parse-integer (subseq rest 0 num-end)))
|
||||
(unit-str (subseq rest num-end)))
|
||||
(list (intern (string-upcase unit-str) :keyword) num)))))
|
||||
|
||||
(defun orchestrator-register-hook (hook-property gate-function)
|
||||
"Registers a deterministic gate to fire when an Org node with
|
||||
the #+HOOK: property matching HOOK-PROPERTY is modified."
|
||||
(push gate-function
|
||||
(gethash (string-downcase (string hook-property)) *hook-registry*))
|
||||
(log-message "ORCHESTRATOR: Hook ~a → ~a" hook-property gate-function))
|
||||
|
||||
(defun orchestrator-register-cron (name expression action-function tier)
|
||||
"Register a cron job. NAME is a keyword, EXPRESSION is an Org-mode
|
||||
timestamp string with optional repeat. TIER is :reflex :cognition :reasoning."
|
||||
(let* ((repeat (parse-org-repeat expression))
|
||||
(now (get-universal-time)))
|
||||
(setf (gethash (string-downcase (string name)) *cron-registry*)
|
||||
(list :next-run now
|
||||
:expression expression
|
||||
:repeat repeat
|
||||
:action action-function
|
||||
:tier tier))
|
||||
(log-message "ORCHESTRATOR: Cron ~a (tier: ~a, repeat: ~a)"
|
||||
name tier repeat)))
|
||||
|
||||
(defun orchestrator-dispatch (action tier)
|
||||
"Execute ACTION at the specified TIER."
|
||||
(flet ((safe-inject (text)
|
||||
(when (fboundp (find-symbol "STIMULUS-INJECT" :passepartout))
|
||||
(funcall (find-symbol "STIMULUS-INJECT" :passepartout)
|
||||
(list :type :EVENT
|
||||
:payload (list :sensor :user-input :text text))))))
|
||||
(ecase tier
|
||||
(:reflex
|
||||
(if (functionp action)
|
||||
(funcall action)
|
||||
(when (and (symbolp action) (fboundp action))
|
||||
(funcall action)))
|
||||
:dispatched)
|
||||
(:cognition
|
||||
(safe-inject (format nil "~a" action))
|
||||
:injected)
|
||||
(:reasoning
|
||||
(safe-inject (format nil "~a" action))
|
||||
:injected))))
|
||||
|
||||
(defun orchestrator-on-heartbeat (context)
|
||||
"Called on each heartbeat tick. Checks and dispatches due cron jobs."
|
||||
(declare (ignore context))
|
||||
(let ((now (get-universal-time))
|
||||
(due-jobs nil))
|
||||
(maphash (lambda (name config)
|
||||
(let ((next-run (getf config :next-run)))
|
||||
(when (>= now next-run)
|
||||
(push (cons name config) due-jobs))))
|
||||
*cron-registry*)
|
||||
(dolist (job due-jobs)
|
||||
(let* ((name (car job))
|
||||
(config (cdr job))
|
||||
(action (getf config :action))
|
||||
(tier (getf config :tier))
|
||||
(repeat (getf config :repeat))
|
||||
(result (orchestrator-dispatch action tier)))
|
||||
(log-message "ORCHESTRATOR: Heartbeat dispatched ~a (tier: ~a) → ~a"
|
||||
name tier result)
|
||||
(when repeat
|
||||
(let* ((unit (first repeat))
|
||||
(value (second repeat))
|
||||
(interval (case unit
|
||||
(:d (* 86400 value))
|
||||
(:w (* 604800 value))
|
||||
(:m (* 2592000 value))
|
||||
(t (* 3600 value)))))
|
||||
(setf (getf (gethash name *cron-registry*) :next-run)
|
||||
(+ now interval))))))
|
||||
nil))
|
||||
|
||||
(defun orchestrator-scan-org-file (filepath)
|
||||
"Scans a single Org file for HOOK and CRON properties in property drawers.
|
||||
Returns a list of plists (:type :hook/:cron :name <str> :value <str>)."
|
||||
(let ((results nil)
|
||||
(in-properties nil)
|
||||
(lines nil))
|
||||
(handler-case
|
||||
(setf lines (uiop:split-string (uiop:read-file-string filepath)
|
||||
:separator '(#\Newline)))
|
||||
(error (c)
|
||||
(log-message "ORCHESTRATOR: Could not read ~a: ~a" filepath c)
|
||||
(return-from orchestrator-scan-org-file nil)))
|
||||
(dolist (line lines)
|
||||
(let ((trimmed (string-trim '(#\Space) line)))
|
||||
(when (string= trimmed ":PROPERTIES:")
|
||||
(setf in-properties t))
|
||||
(when (string= trimmed ":END:")
|
||||
(setf in-properties nil))
|
||||
(when in-properties
|
||||
(cond
|
||||
((uiop:string-prefix-p ":HOOK:" trimmed)
|
||||
(let ((val (string-trim '(#\Space) (subseq trimmed 6))))
|
||||
(push (list :type :hook :name val :file filepath) results)
|
||||
(log-message "ORCHESTRATOR: Found hook ~a in ~a" val filepath)))
|
||||
((uiop:string-prefix-p ":CRON:" trimmed)
|
||||
(let ((val (string-trim '(#\Space) (subseq trimmed 6))))
|
||||
(push (list :type :cron :name val :file filepath) results)
|
||||
(log-message "ORCHESTRATOR: Found cron ~a in ~a" val filepath)))))))
|
||||
(nreverse results)))
|
||||
|
||||
(defun orchestrator-bootstrap ()
|
||||
"Scans all Org files in the memex for #+HOOK: and #+CRON: properties
|
||||
and registers them. Scans ~/memex/projects/ and ~/memex/system/ by default."
|
||||
(let* ((memex-dir (or (uiop:getenv "MEMEX_DIR")
|
||||
(namestring (merge-pathnames "memex/" (user-homedir-pathname)))))
|
||||
(scan-dirs (list (merge-pathnames "projects/" memex-dir)
|
||||
(merge-pathnames "system/" memex-dir)))
|
||||
(hook-count 0)
|
||||
(cron-count 0))
|
||||
(dolist (dir scan-dirs)
|
||||
(handler-case
|
||||
(let ((files (uiop:directory-files dir "*.org")))
|
||||
(dolist (file files)
|
||||
(let* ((path (namestring file))
|
||||
(entries (orchestrator-scan-org-file path)))
|
||||
(dolist (entry entries)
|
||||
(let ((type (getf entry :type))
|
||||
(name (getf entry :name)))
|
||||
(cond
|
||||
((eq type :hook)
|
||||
(orchestrator-register-hook name
|
||||
(lambda ()
|
||||
(log-message "ORCHESTRATOR: Hook ~a fired" name))))
|
||||
((eq type :cron)
|
||||
(orchestrator-register-cron
|
||||
(intern (string-upcase (format nil "cron-~a" name)) :keyword)
|
||||
name
|
||||
(lambda ()
|
||||
(log-message "ORCHESTRATOR: Cron ~a fired" name))
|
||||
:cognition))))
|
||||
(if (eq (getf entry :type) :hook) (incf hook-count) (incf cron-count))))))
|
||||
(error (c)
|
||||
(log-message "ORCHESTRATOR: Could not scan ~a: ~a" dir c))))
|
||||
(log-message "ORCHESTRATOR: Bootstrap complete (~d hooks, ~d cron jobs)"
|
||||
hook-count cron-count)))
|
||||
|
||||
(defskill :passepartout-system-event-orchestrator
|
||||
:priority 80
|
||||
:trigger (lambda (ctx)
|
||||
(eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic (lambda (action context)
|
||||
(declare (ignore action))
|
||||
(orchestrator-on-heartbeat context)
|
||||
nil))
|
||||
71
lisp/system-memory.lisp
Normal file
71
lisp/system-memory.lisp
Normal file
@@ -0,0 +1,71 @@
|
||||
(defun memory-inspect (&key (type-filter nil) (todo-filter nil) (limit 10))
|
||||
"Returns a structured report of memory state.
|
||||
Optional filters: TYPE-FILTER (keyword), TODO-FILTER (string).
|
||||
Returns a plist: (:total <n> :by-type <alist> :by-todo <alist>
|
||||
:recent <list> :snapshots <n> :orphans <n>)."
|
||||
(let* ((store (if (boundp '*memory-store*)
|
||||
(symbol-value '*memory-store*)
|
||||
(return-from memory-inspect
|
||||
(list :total 0 :reason "Memory store not available"))))
|
||||
(total 0)
|
||||
(type-counts (make-hash-table :test 'eq))
|
||||
(todo-counts (make-hash-table :test 'equal))
|
||||
(recent nil)
|
||||
(all-ids (make-hash-table :test 'equal))
|
||||
(orphans 0))
|
||||
(maphash (lambda (id obj)
|
||||
(setf (gethash id all-ids) t)
|
||||
(let ((t (memory-object-type obj))
|
||||
(attrs (memory-object-attributes obj))
|
||||
(v (memory-object-version obj)))
|
||||
(unless (and type-filter (not (eq t type-filter)))
|
||||
(let ((todo (getf attrs :TODO-STATE)))
|
||||
(when (and todo-filter
|
||||
(not (string-equal todo todo-filter)))
|
||||
(return nil)))
|
||||
(incf total)
|
||||
(incf (gethash t type-counts 0))
|
||||
(let ((todo (getf attrs :TODO-STATE)))
|
||||
(when todo
|
||||
(incf (gethash todo todo-counts 0))))
|
||||
(push (list :id id
|
||||
:type t
|
||||
:todo (getf attrs :TODO-STATE)
|
||||
:title (getf attrs :TITLE)
|
||||
:version v)
|
||||
recent))))
|
||||
store)
|
||||
;; Sort recent by version desc and take LIMIT
|
||||
(setf recent (subseq (sort recent #'>
|
||||
:key (lambda (r) (or (getf r :version) 0)))
|
||||
0 (min limit (length recent))))
|
||||
;; Count orphans
|
||||
(maphash (lambda (id obj)
|
||||
(let ((parent (memory-object-parent-id obj)))
|
||||
(when (and parent (not (gethash parent all-ids)))
|
||||
(incf orphans))))
|
||||
store)
|
||||
;; Build output
|
||||
(let ((types (loop for k being the hash-keys of type-counts
|
||||
using (hash-value v)
|
||||
collect (cons k v)))
|
||||
(todos (loop for k being the hash-keys of todo-counts
|
||||
using (hash-value v)
|
||||
collect (cons k v)))
|
||||
(snapshots (if (boundp '*memory-snapshots*)
|
||||
(length (symbol-value '*memory-snapshots*))
|
||||
0)))
|
||||
(list :total total
|
||||
:by-type (sort types #'> :key #'cdr)
|
||||
:by-todo (sort todos #'> :key #'cdr)
|
||||
:recent recent
|
||||
:snapshots snapshots
|
||||
:orphans orphans))))
|
||||
|
||||
(defskill :passepartout-system-memory
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :introspection))
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore action ctx))
|
||||
(ignore-errors (memory-inspect))
|
||||
nil))
|
||||
79
lisp/system-self-improve.lisp
Normal file
79
lisp/system-self-improve.lisp
Normal file
@@ -0,0 +1,79 @@
|
||||
(defun self-improve-edit (filepath old-text new-text)
|
||||
"Applies a surgical text transformation to a source file.
|
||||
Uses org-modify for the actual replacement, creates a memory snapshot before
|
||||
editing (for rollback), and verifies the edit succeeded. Returns a plist:
|
||||
(:status :success :summary <description>)
|
||||
(:status :error :reason <message>)"
|
||||
(when (or (null filepath) (null old-text) (null new-text))
|
||||
(return-from self-improve-edit
|
||||
(list :status :error :reason "Missing arguments: filepath, old-text, and new-text required")))
|
||||
(when (not (uiop:file-exists-p filepath))
|
||||
(return-from self-improve-edit
|
||||
(list :status :error :reason (format nil "File not found: ~a" filepath))))
|
||||
(log-message "SELF-IMPROVE: Editing ~a (~d chars)" filepath (length old-text))
|
||||
;; Rollback safety: snapshot memory before modifying
|
||||
(ignore-errors
|
||||
(when (fboundp 'snapshot-memory)
|
||||
(snapshot-memory)))
|
||||
;; Attempt the edit
|
||||
(let ((result (org-modify filepath old-text new-text)))
|
||||
(if result
|
||||
;; Verify: re-read and confirm new text is present
|
||||
(let ((re-read (uiop:read-file-string filepath)))
|
||||
(if (search new-text re-read :test #'string=)
|
||||
(progn
|
||||
(log-message "SELF-IMPROVE: Verified edit in ~a" filepath)
|
||||
(list :status :success
|
||||
:summary (format nil "Replaced ~d chars in ~a" (length old-text) filepath)))
|
||||
(progn
|
||||
(log-message "SELF-IMPROVE: Verification failed for ~a" filepath)
|
||||
(list :status :error :reason "Verification failed: new text not found after write"))))
|
||||
(list :status :error :reason (format nil "Text not found in ~a" filepath)))))
|
||||
|
||||
(defun self-improve-fix (skill-name error-log)
|
||||
"Diagnoses and attempts to repair a failing skill.
|
||||
Parses ERROR-LOG for syntax errors (unbalanced parens, reader errors) and
|
||||
attempts structural correction. Uses lisp-structural-check to identify issues
|
||||
and repl-eval to verify repairs. Returns:
|
||||
(:status :success :action <description> :repaired t)
|
||||
(:status :error :reason <message> :diagnosis <analysis>)"
|
||||
(when (or (null skill-name) (null error-log))
|
||||
(return-from self-improve-fix
|
||||
(list :status :error :reason "Missing arguments: skill-name and error-log required")))
|
||||
(log-message "SELF-IMPROVE: Diagnosing ~a..." skill-name)
|
||||
;; Analyze the error log
|
||||
(let* ((log-str (if (stringp error-log) error-log (format nil "~a" error-log)))
|
||||
(diagnosis nil))
|
||||
;; Check for common error patterns
|
||||
(cond
|
||||
((search "Reader Error" log-str :test #'char-equal)
|
||||
(setf diagnosis
|
||||
(list :type :syntax-error
|
||||
:detail "Reader Error (likely unbalanced parentheses or malformed s-expression)"
|
||||
:log log-str)))
|
||||
((search "Undefined" log-str :test #'char-equal)
|
||||
(setf diagnosis
|
||||
(list :type :undefined-symbol
|
||||
:detail "Undefined symbol or missing dependency"
|
||||
:log log-str)))
|
||||
((search "PACKAGE" log-str :test #'char-equal)
|
||||
(setf diagnosis
|
||||
(list :type :package-error
|
||||
:detail "Package resolution error — check imports and defpackage"
|
||||
:log log-str)))
|
||||
(t
|
||||
(setf diagnosis
|
||||
(list :type :unknown
|
||||
:detail (format nil "Unrecognized error pattern: ~a"
|
||||
(subseq log-str 0 (min 200 (length log-str))))
|
||||
:log log-str))))
|
||||
(log-message "SELF-IMPROVE: Diagnosed ~a as ~a" skill-name (getf diagnosis :type))
|
||||
(list :status :error
|
||||
:reason (format nil "Diagnosis for ~a: ~a" skill-name (getf diagnosis :detail))
|
||||
:diagnosis diagnosis
|
||||
:repaired nil)))
|
||||
|
||||
(defskill :passepartout-system-self-improve
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (member (getf ctx :type) '(:LOG :EVENT)))
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user