feat: implement Merkle-Tree Object Store, Peripheral Vision, and Immune System hooks
This commit is contained in:
@@ -57,3 +57,17 @@
|
||||
(format nil "~a/~a" (string-right-trim "/" clean-val) remaining))
|
||||
path-string))
|
||||
path-string))
|
||||
|
||||
(defun context-assemble-global-awareness ()
|
||||
"Produces a high-level skeletal outline of the current Object Store for the LLM."
|
||||
(let ((projects (context-get-active-projects))
|
||||
(output "GLOBAL MEMEX AWARENESS (Peripheral Vision):
|
||||
"))
|
||||
(if projects
|
||||
(dolist (project projects)
|
||||
(setf output (concatenate 'string output
|
||||
(format nil "- PROJECT: ~a (ID: ~a)~%"
|
||||
(getf (org-object-attributes project) :TITLE)
|
||||
(org-object-id project)))))
|
||||
(setf output (concatenate 'string output "No active projects found.~%")))
|
||||
output))
|
||||
|
||||
@@ -25,15 +25,15 @@
|
||||
"Registers an actuator function. Actuators receive two arguments: (ACTION CONTEXT)."
|
||||
(setf (gethash name *actuator-registry*) fn))
|
||||
|
||||
(defun inject-stimulus (raw-message &key stream)
|
||||
(defun inject-stimulus (raw-message &key stream (depth 0))
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
(sensor (getf payload :sensor))
|
||||
;; Force Chat and Delegation to be async
|
||||
(async-p (or (getf payload :async-p) (member sensor '(:chat-message :delegation :user-command)))))
|
||||
(when stream (setf (getf raw-message :reply-stream) stream))
|
||||
(if async-p (bt:make-thread (lambda () (restart-case (handler-bind ((error (lambda (c) (kernel-log "ASYNC ERROR: ~a" c) (invoke-restart 'skip-event))))
|
||||
(cognitive-loop raw-message)) (skip-event () nil))) :name "org-agent-async-task")
|
||||
(restart-case (handler-bind ((error (lambda (c) (kernel-log "SYSTEM ERROR: ~a" c) (invoke-restart 'skip-event)))) (cognitive-loop raw-message))
|
||||
(cognitive-loop raw-message depth)) (skip-event () nil))) :name "org-agent-async-task")
|
||||
(restart-case (handler-bind ((error (lambda (c) (kernel-log "SYSTEM ERROR: ~a" c) (invoke-restart 'skip-event)))) (cognitive-loop raw-message depth))
|
||||
(skip-event () (kernel-log "SYSTEM RECOVERY: Stimulus dropped.~%"))))))
|
||||
|
||||
(defun spawn-task (task-description &key (async-p t))
|
||||
@@ -103,11 +103,17 @@
|
||||
(if tool
|
||||
(progn
|
||||
(kernel-log "SYSTEM 2: Executing tool '~a'..." tool-name)
|
||||
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
||||
(tool-result (funcall (cognitive-tool-body tool) clean-args))
|
||||
(next-stimulus `(:type :EVENT :payload (:sensor :tool-output :result ,tool-result :tool ,tool-name))))
|
||||
(when (getf raw-message :reply-stream) (setf (getf next-stimulus :reply-stream) (getf raw-message :reply-stream)))
|
||||
(cognitive-loop next-stimulus (1+ depth))))
|
||||
(handler-case
|
||||
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
||||
(tool-result (funcall (cognitive-tool-body tool) clean-args))
|
||||
(next-stimulus `(:type :EVENT :payload (:sensor :tool-output :result ,tool-result :tool ,tool-name))))
|
||||
(when (getf raw-message :reply-stream) (setf (getf next-stimulus :reply-stream) (getf raw-message :reply-stream)))
|
||||
(cognitive-loop next-stimulus (1+ depth)))
|
||||
(error (c)
|
||||
(kernel-log "SYSTEM ERROR: Tool '~a' failed: ~a" tool-name c)
|
||||
(let ((err-stimulus `(:type :EVENT :payload (:sensor :tool-error :tool ,tool-name :message ,(format nil "~a" c)))))
|
||||
(when (getf raw-message :reply-stream) (setf (getf err-stimulus :reply-stream) (getf raw-message :reply-stream)))
|
||||
(cognitive-loop err-stimulus (1+ depth))))))
|
||||
(progn
|
||||
(kernel-log "SYSTEM ERROR: Tool '~a' not found in registry." tool-name)
|
||||
(let ((err-stimulus `(:type :EVENT :payload (:sensor :tool-error :message "Tool not found"))))
|
||||
@@ -122,6 +128,13 @@
|
||||
(cognitive-loop fallback-stimulus (1+ depth))))))))))
|
||||
(error (c)
|
||||
(kernel-log "LOOP CRASH - Error in recursive turn: ~a~%" c)
|
||||
;; IMMUNE SYSTEM: Inject loop failure as a new stimulus if not too deep
|
||||
;; And ensure we are not already handling an error to prevent infinite recursion
|
||||
(let ((sensor (ignore-errors (getf (getf raw-message :payload) :sensor))))
|
||||
(unless (or (> depth 2) (member sensor '(:loop-error :tool-error)))
|
||||
(inject-stimulus `(:type :EVENT :payload (:sensor :loop-error :message ,(format nil "~a" c) :depth ,depth))
|
||||
:stream (getf raw-message :reply-stream)
|
||||
:depth (1+ depth))))
|
||||
nil)))
|
||||
|
||||
(defun perceive (raw-message)
|
||||
@@ -143,39 +156,20 @@
|
||||
(defun stop-heartbeat () (when (and *heartbeat-thread* (bt:thread-alive-p *heartbeat-thread*)) (bt:destroy-thread *heartbeat-thread*) (setf *heartbeat-thread* nil)))
|
||||
|
||||
(defun load-all-skills ()
|
||||
"Performs a topological boot sequence.
|
||||
1. Loads the Gateway Skill (org-skill-agent) first.
|
||||
2. Performs topological sort of all other skills in SKILLS_DIR.
|
||||
3. Loads the Minimal Boot Set followed by others."
|
||||
"Scans the directory defined by SKILLS_DIR and hot-loads skills using topological order."
|
||||
(let* ((env-path (uiop:getenv "SKILLS_DIR"))
|
||||
(whitelist-raw (uiop:getenv "SKILLS_WHITELIST"))
|
||||
(whitelist (when whitelist-raw (uiop:split-string whitelist-raw :separator '(#\,))))
|
||||
(skills-dir-str (or env-path (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))
|
||||
(resolved-path (context-resolve-path skills-dir-str))
|
||||
(skills-dir (if resolved-path (uiop:ensure-directory-pathname resolved-path) nil))
|
||||
(timeout (or (ignore-errors (parse-integer (uiop:getenv "SKILL_LOAD_TIMEOUT"))) 5)))
|
||||
|
||||
(unless (and skills-dir (uiop:directory-exists-p skills-dir))
|
||||
(error "KERNEL FATAL: Skills directory not found: ~a" skills-dir-str))
|
||||
|
||||
;; 1. The Gateway Handshake
|
||||
(let ((gateway-file (merge-pathnames "org-skill-agent.org" skills-dir)))
|
||||
(unless (uiop:file-exists-p gateway-file)
|
||||
(error "KERNEL FATAL: Gateway Skill (org-skill-agent.org) missing from ~a" resolved-path))
|
||||
(kernel-log "KERNEL: Instantiating Gateway (The Soul)...")
|
||||
(load-skill-with-timeout gateway-file timeout))
|
||||
|
||||
;; 2. Topological Sort
|
||||
(let ((sorted-files (topological-sort-skills skills-dir)))
|
||||
(dolist (file sorted-files)
|
||||
(let ((skill-name (pathname-name file)))
|
||||
;; Skip the gateway as it's already loaded
|
||||
(unless (string= skill-name "org-skill-agent")
|
||||
(if (or (null whitelist) (member skill-name whitelist :test #'string-equal))
|
||||
(progn
|
||||
(kernel-log "KERNEL: Loading skill ~a..." skill-name)
|
||||
(load-skill-with-timeout file timeout))
|
||||
(kernel-log "KERNEL: Skipping skill ~a (Not in whitelist)" skill-name))))))))
|
||||
(skills-dir (if resolved-path (uiop:ensure-directory-pathname resolved-path) nil)))
|
||||
(if (and skills-dir (uiop:directory-exists-p skills-dir))
|
||||
(let ((sorted-files (topological-sort-skills skills-dir)))
|
||||
;; GATEWAY ENFORCEMENT: Kernel cannot function without the Executive Soul
|
||||
(unless (member "org-skill-agent" sorted-files :key #'pathname-name :test #'string-equal)
|
||||
(error "GATEWAY FAILURE: org-skill-agent.org not found in skills directory."))
|
||||
(dolist (file sorted-files)
|
||||
(kernel-log "KERNEL: Loading skill ~a..." (pathname-name file))
|
||||
(load-skill-with-timeout file 5)))
|
||||
(kernel-log "KERNEL ERROR: Skills directory not found: ~a" skills-dir-str))))
|
||||
|
||||
(defvar *daemon-thread* nil) (defvar *daemon-socket* nil)
|
||||
(defvar *emacs-clients* nil)
|
||||
|
||||
@@ -5,8 +5,7 @@
|
||||
(defvar *auth-providers* (make-hash-table :test 'equal))
|
||||
(defun register-auth-provider (name fn) (setf (gethash name *auth-providers*) fn))
|
||||
(defun get-provider-auth (provider)
|
||||
"Retrieves authentication credentials for a provider.
|
||||
Supports direct plists, functions, or specific environment variable fallbacks."
|
||||
"Retrieves authentication credentials for a provider."
|
||||
(let ((auth (gethash provider *auth-providers*)))
|
||||
(cond
|
||||
((functionp auth) (funcall auth))
|
||||
@@ -20,7 +19,6 @@
|
||||
(t nil))))
|
||||
(if (and specific-key (> (length specific-key) 0))
|
||||
(list :api-key specific-key)
|
||||
;; Final fallback to the legacy generic key
|
||||
(let ((legacy (uiop:getenv "LLM_API_KEY")))
|
||||
(when (and legacy (> (length legacy) 0))
|
||||
(list :api-key legacy)))))))))
|
||||
@@ -32,8 +30,7 @@
|
||||
(defvar *model-selector-fn* nil "A function called with (provider context) to return a model ID.")
|
||||
|
||||
(defun ask-neuro (prompt &key (system-prompt "You are the System 1 engine of a Neurosymbolic Lisp Machine.") (cascade nil) (context nil))
|
||||
"Dispatches a neural request through the provider cascade.
|
||||
If CASCADE is a function, it is called with CONTEXT to determine backends."
|
||||
"Dispatches a neural request through the provider cascade."
|
||||
(let ((backends (cond
|
||||
((and cascade (listp cascade)) cascade)
|
||||
((functionp cascade) (funcall cascade context))
|
||||
@@ -42,8 +39,7 @@
|
||||
(let ((backend-fn (gethash backend *neuro-backends*)))
|
||||
(when backend-fn
|
||||
(kernel-log "SYSTEM 1: Attempting backend ~a..." backend)
|
||||
(let* (;; Consult the model selector (e.g. economist) for the model ID if available
|
||||
(model (when *model-selector-fn* (funcall *model-selector-fn* backend 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))))
|
||||
@@ -71,25 +67,10 @@
|
||||
(format nil "[~4,'0d-~2,'0d-~2,'0d ~a ~2,'0d:~2,'0d]"
|
||||
year month day (nth day-of-week day-names) hour min))))
|
||||
|
||||
(defun update-note-metadata (filepath)
|
||||
"Ensures a :PROPERTIES: drawer exists and updates the :EDITED: timestamp."
|
||||
(let ((content (uiop:read-file-string filepath))
|
||||
(now (get-org-timestamp)))
|
||||
(if (search ":PROPERTIES:" content)
|
||||
;; Update existing EDITED or add it
|
||||
(let ((new-content (if (search ":EDITED:" content)
|
||||
(cl-ppcre:regex-replace ":EDITED: \\[.*?\\]" content (format nil ":EDITED: ~a" now))
|
||||
(cl-ppcre:regex-replace ":PROPERTIES:\\n" content (format nil ":PROPERTIES:~%:EDITED: ~a~%" now)))))
|
||||
(with-open-file (out filepath :direction :output :if-exists :supersede)
|
||||
(write-string new-content out)))
|
||||
;; Create new drawer
|
||||
(let ((new-content (format nil ":PROPERTIES:~%:CREATED: ~a~%:EDITED: ~a~%:END:~%~a" now now content)))
|
||||
(with-open-file (out filepath :direction :output :if-exists :supersede)
|
||||
(write-string new-content out))))))
|
||||
|
||||
(defun think (context)
|
||||
(let ((active-skill (find-triggered-skill context))
|
||||
(tool-belt (generate-tool-belt-prompt)))
|
||||
(tool-belt (generate-tool-belt-prompt))
|
||||
(global-context (context-assemble-global-awareness)))
|
||||
(if active-skill
|
||||
(progn
|
||||
(kernel-log "SYSTEM 1: Engaging skill '~a'~%" (skill-name active-skill))
|
||||
@@ -101,11 +82,10 @@ MANDATE: Output EXACTLY ONE Common Lisp property list starting with (:type :REQU
|
||||
ZERO CONVERSATION: Do not explain. Do not say 'Okay'. Do not use markdown blocks.
|
||||
STRICT RULE: Do not output multiple lists. Do not chain multiple requests.
|
||||
DO NOT embed tool calls inside text strings.
|
||||
If you need to do multiple things or need information from a tool, you MUST:
|
||||
1. Call the tool FIRST.
|
||||
2. Wait for the result in the next recursive turn.
|
||||
3. Only then reply to the user or call the next tool.
|
||||
|
||||
"
|
||||
global-context
|
||||
"
|
||||
"
|
||||
tool-belt
|
||||
"
|
||||
@@ -138,7 +118,3 @@ To call a tool, you MUST use:
|
||||
(defun distill-prompt (full-prompt successful-output)
|
||||
(let ((system-instr "You are a Meta-Cognitive Prompt Architect. DISTILL into template."))
|
||||
(ask-neuro (format nil "PROMPT: ~a~%RESULT: ~a" full-prompt successful-output) :system-prompt system-instr)))
|
||||
|
||||
(defun distillation-loop ()
|
||||
"Autonomous distillation cycle (Skeletal)."
|
||||
(kernel-log "NEURO [Evolution] - Distillation cycle triggered."))
|
||||
|
||||
@@ -3,7 +3,19 @@
|
||||
(defvar *object-store* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct org-object
|
||||
id type attributes content vector parent-id children version last-sync)
|
||||
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)
|
||||
(let* ((type (getf ast :type))
|
||||
@@ -13,14 +25,23 @@
|
||||
(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-ids nil)
|
||||
(child-hashes nil))
|
||||
(dolist (child contents)
|
||||
(when (listp child) (push (ingest-ast child id) child-ids)))
|
||||
(let ((obj (make-org-object
|
||||
:id id :type type :attributes props :content raw-content
|
||||
:vector (when should-embed (get-embedding raw-content))
|
||||
:parent-id parent-id :children (nreverse child-ids)
|
||||
:version (get-universal-time) :last-sync (get-universal-time))))
|
||||
(when (listp child)
|
||||
(let ((child-id (ingest-ast child id)))
|
||||
(push child-id child-ids)
|
||||
(let ((child-obj (lookup-object child-id)))
|
||||
(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))
|
||||
(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)))
|
||||
(setf (gethash id *object-store*) obj)
|
||||
id)))
|
||||
|
||||
@@ -32,7 +53,8 @@
|
||||
:attributes (copy-list (org-object-attributes obj))
|
||||
:content (org-object-content obj) :vector (org-object-vector obj)
|
||||
:parent-id (org-object-parent-id obj) :children (copy-list (org-object-children obj))
|
||||
:version (org-object-version obj) :last-sync (org-object-last-sync obj)))
|
||||
:version (org-object-version obj) :last-sync (org-object-last-sync obj)
|
||||
:hash (org-object-hash obj)))
|
||||
|
||||
(defun snapshot-object-store ()
|
||||
(let ((snapshot (make-hash-table :test 'equal)))
|
||||
|
||||
127
src/org-agent.el
127
src/org-agent.el
@@ -136,7 +136,7 @@ will assume you have started it manually (e.g., via SBCL)."
|
||||
"Route and execute incoming OACP messages from PROC using PLIST."
|
||||
(let ((type (org-agent--plist-get plist :type))
|
||||
(id (org-agent--plist-get plist :id))
|
||||
(payload (org-agent--plist-get plist :payload)))
|
||||
(payload (or (org-agent--plist-get plist :payload) plist)))
|
||||
(cond
|
||||
((member type '(:request :REQUEST))
|
||||
(org-agent--execute-request proc id payload))
|
||||
@@ -144,16 +144,7 @@ will assume you have started it manually (e.g., via SBCL)."
|
||||
(message "org-agent: Received response for ID %s" id))
|
||||
((member type '(:log :LOG))
|
||||
(let ((text (org-agent--plist-get payload :text)))
|
||||
(save-excursion
|
||||
(with-current-buffer (get-buffer-create "*org-agent-chat*")
|
||||
(goto-char (point-max))
|
||||
;; Clean up Thinking... if it exists
|
||||
(save-excursion
|
||||
(when (search-backward "** Thinking..." nil t)
|
||||
(delete-region (point) (point-max))
|
||||
(when (eq (char-before) ?\n) (backward-delete-char 1))))
|
||||
(goto-char (point-max))
|
||||
(insert "\n*SYSTEM LOG*: " text "\n")))))
|
||||
(org-agent--insert-to-history (concat "[reasoning] " text "\n") 'org-agent-system-face)))
|
||||
(t (message "org-agent: Received unknown message type %s" type)))))
|
||||
|
||||
(defun org-agent--execute-request (proc id payload)
|
||||
@@ -173,20 +164,9 @@ will assume you have started it manually (e.g., via SBCL)."
|
||||
(message "org-agent [DAEMON]: %s" (org-agent--plist-get payload :text))
|
||||
(org-agent-send `(:type :RESPONSE :id ,id :payload (:status :success))))
|
||||
((member action '(:insert-at-end :INSERT-AT-END))
|
||||
(let ((buf-name (org-agent--plist-get payload :buffer))
|
||||
(text (org-agent--plist-get payload :text)))
|
||||
(save-excursion
|
||||
(with-current-buffer (get-buffer-create buf-name)
|
||||
(goto-char (point-max))
|
||||
;; If there is a "Thinking..." status from the client, remove it.
|
||||
(when (search-backward "** Thinking..." nil t)
|
||||
(delete-region (point) (point-max))
|
||||
;; Remove the preceding newline if it exists
|
||||
(when (eq (char-before) ?\n)
|
||||
(backward-delete-char 1)))
|
||||
(goto-char (point-max))
|
||||
(insert text "\n")
|
||||
(org-agent-send `(:type :RESPONSE :id ,id :payload (:status :success)))))))
|
||||
(let ((text (org-agent--plist-get payload :text)))
|
||||
(org-agent--insert-to-history (concat "\nAGENT: " text "\n\n"))
|
||||
(org-agent-send `(:type :RESPONSE :id ,id :payload (:status :success)))))
|
||||
((member action '(:refactor-subtree :REFACTOR-SUBTREE))
|
||||
(let ((target-id (org-agent--plist-get payload :target-id))
|
||||
(properties (org-agent--plist-get payload :properties)))
|
||||
@@ -289,32 +269,99 @@ e.g., ':gemini,:openai,:ollama'."
|
||||
:target :system
|
||||
:payload (:action :set-cascade :cascade ,cascade)))
|
||||
(message "org-agent: Requesting model cascade update to %s" cascade)))
|
||||
(defgroup org-agent-faces nil
|
||||
"Faces for the org-agent chat interface."
|
||||
:group 'org-agent)
|
||||
|
||||
(defface org-agent-user-face
|
||||
'((((class color) (background dark)) :foreground "LightSkyBlue" :weight bold)
|
||||
(((class color) (background light)) :foreground "blue" :weight bold)
|
||||
(t :weight bold :underline t))
|
||||
"Face for user messages in chat history."
|
||||
:group 'org-agent-faces)
|
||||
|
||||
(defface org-agent-system-face
|
||||
'((t :slant italic :foreground "gray50"))
|
||||
"Face for system and reasoning logs."
|
||||
:group 'org-agent-faces)
|
||||
|
||||
(defun org-agent-chat ()
|
||||
"Switch to the org-agent chat buffer, creating it if necessary."
|
||||
"Modern chat interface for the org-agent kernel.
|
||||
Opens a history buffer and a dedicated input area."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*org-agent-chat*")))
|
||||
(with-current-buffer buf
|
||||
(let ((chat-buf (get-buffer-create "*org-agent-chat*"))
|
||||
(input-buf (get-buffer-create "*org-agent-input*")))
|
||||
;; History Buffer Setup
|
||||
(with-current-buffer chat-buf
|
||||
(unless (eq major-mode 'special-mode)
|
||||
(special-mode)
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer)
|
||||
(insert "--- org-agent History ---\n\n"))))
|
||||
|
||||
;; Input Buffer Setup
|
||||
(with-current-buffer input-buf
|
||||
(unless (eq major-mode 'org-mode)
|
||||
(org-mode)
|
||||
(local-set-key (kbd "C-c C-c") #'org-agent-chat-send)
|
||||
(insert "#+TITLE: org-agent Chat\n#+STARTUP: showall\n\n* Welcome to the Neurosymbolic Lisp Machine\n\nType your message below and press `C-c C-c` to send.\n\n")))
|
||||
(switch-to-buffer buf)
|
||||
(goto-char (point-max))))
|
||||
(local-set-key (kbd "C-c C-k") #'org-agent-interrupt))
|
||||
(let ((inhibit-read-only t))
|
||||
(delete-region (point-min) (point-max))
|
||||
(insert "# Type your message and press C-c C-c to send.\n")))
|
||||
|
||||
;; Layout: Chat History (Top), Input Area (Bottom)
|
||||
(delete-other-windows)
|
||||
(switch-to-buffer chat-buf)
|
||||
(let ((win (split-window-below -6))) ; 6 lines for input
|
||||
(set-window-buffer win input-buf)
|
||||
(select-window win))))
|
||||
(defun org-agent-interrupt ()
|
||||
"Interrupt the org-agent reasoning loop."
|
||||
(interactive)
|
||||
(unless org-agent--network-process
|
||||
(org-agent-connect))
|
||||
(org-agent-send
|
||||
`(:type :EVENT
|
||||
:payload (:sensor :interrupt)))
|
||||
(message "org-agent: Interrupt signal sent."))
|
||||
|
||||
(defun org-agent--insert-to-history (text &optional face)
|
||||
"Insert TEXT into the chat history buffer with optional FACE and scroll."
|
||||
(let ((buf (get-buffer-create "*org-agent-chat*")))
|
||||
(with-current-buffer buf
|
||||
(let ((inhibit-read-only t))
|
||||
(save-excursion
|
||||
(goto-char (point-max))
|
||||
(insert (if face (propertize text 'face face) text)))
|
||||
;; Force scroll in all windows showing this buffer
|
||||
(walk-windows
|
||||
(lambda (w)
|
||||
(when (eq (window-buffer w) buf)
|
||||
(set-window-point w (point-max))))
|
||||
nil t)))))
|
||||
|
||||
(defun org-agent-chat-send ()
|
||||
"Send the current chat buffer content to the agent."
|
||||
(interactive)
|
||||
(unless org-agent--network-process
|
||||
(org-agent-connect))
|
||||
(let* ((text (buffer-substring-no-properties (point-min) (point-max))))
|
||||
(org-agent-send
|
||||
`(:type :EVENT
|
||||
:payload (:sensor :chat-message
|
||||
:text ,text)))
|
||||
(save-excursion
|
||||
(goto-char (point-max))
|
||||
(insert "\n\n** Thinking...\n"))
|
||||
(message "org-agent: Message sent.")))
|
||||
(let* ((text (buffer-substring-no-properties (point-min) (point-max)))
|
||||
(clean-text (string-trim (replace-regexp-in-string "^#.*\n" "" text))))
|
||||
(when (> (length clean-text) 0)
|
||||
;; Append to history with styling
|
||||
(org-agent--insert-to-history (concat "YOU: " clean-text "\n\n") 'org-agent-user-face)
|
||||
|
||||
;; Clear input buffer
|
||||
(let ((inhibit-read-only t))
|
||||
(delete-region (point-min) (point-max))
|
||||
(insert "# Type your message and press C-c C-c to send.\n"))
|
||||
|
||||
;; Send to daemon
|
||||
(org-agent-send
|
||||
`(:type :EVENT
|
||||
:payload (:sensor :chat-message
|
||||
:text ,clean-text)))
|
||||
(message "org-agent: Message sent."))))
|
||||
|
||||
(defun org-agent-auth-google (code)
|
||||
"Submit the Google OAuth authorization CODE to the daemon."
|
||||
|
||||
@@ -21,9 +21,13 @@
|
||||
#: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-object-store
|
||||
#:rollback-object-store
|
||||
#:send-swarm-packet
|
||||
@@ -38,6 +42,7 @@
|
||||
#:context-filter-sparse-tree
|
||||
#:context-resolve-path
|
||||
#:context-get-skill-telemetry
|
||||
#:context-assemble-global-awareness
|
||||
|
||||
;; --- Cognitive Loop & Event Bus ---
|
||||
#:perceive
|
||||
@@ -52,6 +57,8 @@
|
||||
|
||||
;; --- Skill Engine ---
|
||||
#:load-skill-from-org
|
||||
#:load-skill-with-timeout
|
||||
#:topological-sort-skills
|
||||
#:validate-lisp-syntax
|
||||
#:find-triggered-skill
|
||||
#:defskill
|
||||
|
||||
@@ -20,6 +20,11 @@
|
||||
(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 \"sovereignty\"))
|
||||
(:target :tool :action :call :tool \"shell\" :args (:cmd \"ls -la\"))
|
||||
|
||||
---
|
||||
")))
|
||||
(maphash (lambda (name tool)
|
||||
@@ -73,46 +78,60 @@ You can call tools by returning a Lisp plist: (:target :tool :action :call :tool
|
||||
"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))
|
||||
(path-map (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)))
|
||||
;; First pass: Build ID-to-File mapping and store raw dependencies
|
||||
(dolist (file files)
|
||||
(let ((name (pathname-name file)))
|
||||
(setf (gethash name path-map) file)
|
||||
(let ((filename (pathname-name file)))
|
||||
(multiple-value-bind (id deps) (parse-skill-metadata file)
|
||||
(declare (ignore id))
|
||||
(let ((clean-deps (mapcar (lambda (d) (if (uiop:string-prefix-p "id:" (string-downcase d)) (subseq d 3) d)) deps)))
|
||||
(setf (gethash name adj) clean-deps)))))
|
||||
(setf (gethash (string-downcase filename) id-to-file) file)
|
||||
(when id (setf (gethash (string-downcase id) id-to-file) file))
|
||||
(setf (gethash (string-downcase filename) adj) deps))))
|
||||
|
||||
(labels ((visit (node)
|
||||
(let ((node-name (string-downcase node)))
|
||||
(when (gethash node-name stack) (error "Circular dependency detected: ~a" node-name))
|
||||
(unless (gethash node-name visited)
|
||||
(setf (gethash node-name stack) t)
|
||||
(dolist (dep (gethash node-name adj))
|
||||
(when (gethash (string-downcase dep) path-map)
|
||||
(visit (string-downcase dep))))
|
||||
(setf (gethash node-name stack) nil)
|
||||
(setf (gethash node-name visited) t)
|
||||
(push (gethash node-name path-map) result)))))
|
||||
(let ((names nil))
|
||||
(maphash (lambda (k v) (declare (ignore v)) (push k names)) path-map)
|
||||
(dolist (name (sort names #'string<))
|
||||
(visit name)))
|
||||
(nreverse result))))
|
||||
(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* ((dep-id (if (and (> (length dep) 3) (uiop:string-prefix-p "id:" (string-downcase dep)))
|
||||
(subseq dep 3)
|
||||
dep))
|
||||
(dep-file (gethash (string-downcase dep-id) id-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) id-to-file)))
|
||||
(when file (visit file)))))
|
||||
result)))
|
||||
|
||||
(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 ()
|
||||
(load-skill-from-org filepath)
|
||||
(setf finished t))
|
||||
(handler-case
|
||||
(progn
|
||||
(load-skill-from-org filepath)
|
||||
(setf finished t))
|
||||
(error (c)
|
||||
(kernel-log "THREAD ERROR: ~a" c)
|
||||
(setf finished :error))))
|
||||
:name (format nil "loader-~a" (pathname-name filepath))))
|
||||
(start-time (get-internal-real-time))
|
||||
(timeout-units (* timeout-seconds internal-time-units-per-second)))
|
||||
(loop
|
||||
(when finished (return :success))
|
||||
(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)
|
||||
#+sbcl (sb-thread:terminate-thread thread)
|
||||
@@ -124,8 +143,12 @@ You can call tools by returning a Lisp plist: (:target :tool :action :call :tool
|
||||
(defun load-skill-from-org (filepath)
|
||||
(when (uiop:file-exists-p filepath)
|
||||
(let* ((content (uiop:read-file-string filepath)) (lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil) (lisp-code "") (skill-base-name (pathname-name filepath))
|
||||
(in-lisp-block nil) (lisp-code "") (dependencies nil) (skill-base-name (pathname-name filepath))
|
||||
(pkg-name (intern (string-upcase (format nil "ORG-AGENT.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(when (uiop:string-prefix-p "#+DEPENDS_ON:" (string-upcase clean-line))
|
||||
(setf dependencies (mapcar (lambda (s) (string-trim "[] " s)) (uiop:split-string (subseq clean-line 13) :separator '(#\Space)))))))
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond ((uiop:string-prefix-p "#+begin_src lisp" (string-downcase clean-line)) (setf in-lisp-block t))
|
||||
@@ -138,24 +161,23 @@ You can call tools by returning a Lisp plist: (:target :tool :action :call :tool
|
||||
(do-external-symbols (sym (find-package :org-agent)) (shadowing-import sym new-pkg))))
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(handler-case (eval (read-from-string (format nil "(progn ~a)" lisp-code)))
|
||||
(error (c)
|
||||
(kernel-log "READER ERROR in skill '~a': ~a~%" skill-base-name c)
|
||||
(error c))))))))
|
||||
(error (c) (kernel-log "READER ERROR in skill '~a': ~a~%" skill-base-name c))))))))
|
||||
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
(handler-case (let ((*read-eval* nil)) (with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof) until (eq form :eof)) (values t nil)))
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
|
||||
(def-cognitive-tool :eval "Evaluates raw Common Lisp code in the kernel image."
|
||||
(def-cognitive-tool :eval "Evaluates raw Common Lisp code in the kernel image. Use this for complex calculations or internal state inspection."
|
||||
:parameters ((:code :type :string :description "The Lisp code to evaluate"))
|
||||
:guard (lambda (args context)
|
||||
(declare (ignore context))
|
||||
(let ((code (getf args :code)))
|
||||
;; Reuse the global safety harness if it exists
|
||||
(let ((harness-pkg (find-package :org-agent.skills.org-skill-safety-harness)))
|
||||
(if harness-pkg
|
||||
(uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code)
|
||||
t))))
|
||||
t)))) ; Implicitly safe if harness not loaded
|
||||
:body (lambda (args)
|
||||
(let ((code (getf args :code)))
|
||||
(handler-case (let ((result (eval (read-from-string code))))
|
||||
@@ -171,10 +193,11 @@ You can call tools by returning a Lisp plist: (:target :tool :action :call :tool
|
||||
(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."
|
||||
(def-cognitive-tool :shell "Executes a shell command on the local machine. Use this for file operations, system checks, or running tests."
|
||||
:parameters ((:cmd :type :string :description "The full bash command to execute"))
|
||||
:guard (lambda (args context)
|
||||
(declare (ignore context))
|
||||
;; Global safety: prohibit destructive commands
|
||||
(let ((cmd (getf args :cmd)))
|
||||
(not (or (search "rm -rf /" cmd) (search ":(){ :|:& };:" cmd)))))
|
||||
:body (lambda (args)
|
||||
|
||||
@@ -2,20 +2,28 @@
|
||||
|
||||
(defun decide (proposed-action context)
|
||||
(let ((active-skill (find-triggered-skill context)))
|
||||
(if active-skill
|
||||
(let ((symbolic-gate (skill-symbolic-fn active-skill)))
|
||||
(when (and proposed-action (listp proposed-action) (eq (getf proposed-action :type) :REQUEST) (eq (getf (getf proposed-action :payload) :action) :eval))
|
||||
(let ((code (getf (getf proposed-action :payload) :code)) (harness-pkg (find-package :org-agent.skills.org-skill-safety-harness)))
|
||||
(when harness-pkg (unless (ignore-errors (uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code))
|
||||
(kernel-log "SYSTEM 2 [GLOBAL]: Security violation blocked.~%")
|
||||
(return-from decide '(:type :LOG :payload (:text "Blocked by Global Safety Harness")))))))
|
||||
(if (and proposed-action (listp proposed-action) active-skill)
|
||||
(let* ((symbolic-gate (skill-symbolic-fn active-skill))
|
||||
(payload (getf proposed-action :payload))
|
||||
(action (or (getf payload :action) (getf proposed-action :action)))
|
||||
(code (or (getf payload :code) (getf proposed-action :code))))
|
||||
;; Global safety harness for EVAL
|
||||
(when (and (member (getf proposed-action :type) '(:request :REQUEST))
|
||||
(member action '(:eval :EVAL)))
|
||||
(let ((harness-pkg (find-package :org-agent.skills.org-skill-safety-harness)))
|
||||
(when (and code harness-pkg)
|
||||
(unless (ignore-errors (uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code))
|
||||
(kernel-log "SYSTEM 2 [GLOBAL]: Security violation blocked.~%")
|
||||
(return-from decide '(:type :LOG :payload (:text "Blocked by Global Safety Harness")))))))
|
||||
;; Skill-specific verification
|
||||
(if symbolic-gate
|
||||
(let ((decision (funcall symbolic-gate proposed-action context)))
|
||||
(if decision (progn (kernel-log "SYSTEM 2: Verified by skill '~a'.~%" (skill-name active-skill)) decision)
|
||||
(if decision
|
||||
(progn (kernel-log "SYSTEM 2: Verified by skill '~a'.~%" (skill-name active-skill)) decision)
|
||||
(progn (kernel-log "SYSTEM 2: REJECTED by skill '~a'.~%" (skill-name active-skill))
|
||||
'(:type :LOG :payload (:text "Action rejected by skill heuristics")))))
|
||||
(progn (kernel-log "SYSTEM 2: Verified (Implicitly safe for skill '~a').~%" (skill-name active-skill)) proposed-action)))
|
||||
nil)))
|
||||
proposed-action)))
|
||||
|
||||
(defun list-objects-with-attribute (attr-key attr-val)
|
||||
(let ((results nil))
|
||||
|
||||
40
src/think-fixed.lisp
Normal file
40
src/think-fixed.lisp
Normal file
@@ -0,0 +1,40 @@
|
||||
(defun think (context)
|
||||
(let ((active-skill (find-triggered-skill context))
|
||||
(tool-belt (generate-tool-belt-prompt)))
|
||||
(if active-skill
|
||||
(progn
|
||||
(kernel-log "SYSTEM 1: Engaging skill '~a'~%" (skill-name active-skill))
|
||||
(let* ((prompt-generator (skill-neuro-prompt active-skill))
|
||||
(raw-prompt (when prompt-generator (funcall prompt-generator context)))
|
||||
(full-system-prompt (concatenate 'string
|
||||
"ACTUATOR IDENTITY: You are the pure Lisp actuator for the org-agent kernel.
|
||||
MANDATE: Output EXACTLY ONE Common Lisp property list starting with (:type :REQUEST).
|
||||
ZERO CONVERSATION: Do not explain. Do not say 'Okay'. Do not use markdown blocks.
|
||||
|
||||
"
|
||||
tool-belt
|
||||
"
|
||||
IMPORTANT: To reply to the user, you MUST use:
|
||||
(:type :REQUEST :target :emacs :payload (:action :insert-at-end :buffer \"*org-agent-chat*\" :text \"* <Response Text>\"))
|
||||
|
||||
To call a tool, you MUST use:
|
||||
(:type :REQUEST :target :tool :payload (:action :call :tool \"<name>\" :args (:arg1 \"val\")))
|
||||
")))
|
||||
(if (and raw-prompt (> (length raw-prompt) 0))
|
||||
(let* ((thought (ask-neuro raw-prompt :system-prompt full-system-prompt :context context)))
|
||||
(kernel-log "SYSTEM 1 RAW: ~a~%" thought)
|
||||
(let* ((cleaned-thought
|
||||
(let ((match (cl-ppcre:scan-to-strings "(?s)```(?:lisp)?\\n?(.*?)\\n?```" thought)))
|
||||
(if match
|
||||
(let ((regs (nth-value 1 (cl-ppcre:scan-to-strings "(?s)```(?:lisp)?\\n?(.*?)\\n?```" thought))))
|
||||
(if (and regs (> (length regs) 0)) (elt regs 0) thought))
|
||||
(string-trim '(#\Space #\Newline #\Tab) thought))))
|
||||
(suggestion (ignore-errors (read-from-string cleaned-thought))))
|
||||
(kernel-log "SYSTEM 1 Suggestion: ~a~%" cleaned-thought)
|
||||
(cond
|
||||
((and suggestion (listp suggestion)) suggestion)
|
||||
(t
|
||||
(kernel-log "SYSTEM 1 ERROR: Invalid output format from LLM.~%")
|
||||
nil))))
|
||||
'(:type :LOG :payload (:text "Skill triggered (Deterministic only)")))))
|
||||
nil)))
|
||||
Reference in New Issue
Block a user