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

CHORE: Prepare for lisp-repair implementation

Browse Source
This commit is contained in:
Amr Gharbeia
2026-04-11 14:25:28 -04:00
parent 393c86c7cf
commit 7eff65505a
14 changed files with 585 additions and 92 deletions
Download Patch File Download Diff File Expand all files Collapse all files

39
src/core.lisp
View File

@@ -90,18 +90,51 @@
(unless (eq (getf signal :type) :EVENT)
(return-from neuro-gate signal))
(kernel-log "GATE [Neuro]: Consulting System 1...")
(let ((thought (think signal)))
(setf (getf signal :proposals) (if thought (list thought) nil))
(let ((thoughts (think signal)))
(setf (getf signal :proposals) (if (and thoughts (listp thoughts) (listp (car thoughts)))
thoughts
(if thoughts (list thoughts) nil)))
(setf (getf signal :status) :thought)
signal))
(defun resolve-consensus (proposals signal)
"Resolves diverging proposals by voting or selecting the safest one."
(declare (ignore signal))
(kernel-log "CONSENSUS: ~a proposals found. Resolving..." (length proposals))
;; Simplified consensus: Majority vote or first safe one
;; For now, we'll select the proposal that appears most frequently.
(let ((counts (make-hash-table :test 'equal)))
(dolist (p proposals)
(incf (gethash p counts 0)))
(let ((winner (first proposals))
(max-count 0))
(maphash (lambda (p count)
(when (> count max-count)
(setq max-count count
winner p)))
counts)
(kernel-log "CONSENSUS: Winner selected with ~a votes." max-count)
winner)))
(defun consensus-gate (signal)
"Resolves multiple proposals into a single candidate action."
(let ((proposals (getf signal :proposals)))
(setf (getf signal :candidate) (first proposals))
(if (and proposals (cdr proposals))
(let ((winner (resolve-consensus proposals signal)))
(setf (getf signal :candidate) winner))
(setf (getf signal :candidate) (first proposals)))
(setf (getf signal :status) :consensus)
signal))
(defun delegate-task (task-id recipient &key context)
"Enqueues a task for another agent or background process."
(kernel-log "ORCHESTRATOR: Delegating task ~a to ~a" task-id recipient)
(inject-stimulus (list :type :EVENT
:payload (list :sensor :delegation
:task-id task-id
:recipient recipient
:context context))))
(defun decide-gate (signal)
"System 2: Safety and validation."
(let ((candidate (getf signal :candidate)))

90
src/neuro.lisp
View File

@@ -27,29 +27,60 @@
(defvar *neuro-backends* (make-hash-table :test 'equal))
(defvar *provider-cascade* '(:openrouter :gemini))
(defvar *consensus-enabled-p* t "If T, ask-neuro queries all backends in parallel.")
(defun register-neuro-backend (name fn) (setf (gethash name *neuro-backends*) fn))
(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."
"Dispatches a neural request through the provider cascade or parallel consensus."
(let ((backends (cond
((and cascade (listp cascade)) cascade)
((functionp cascade) (funcall cascade context))
(t *provider-cascade*))))
(dolist (backend backends)
(let ((backend-fn (gethash backend *neuro-backends*)))
(when backend-fn
(kernel-log "SYSTEM 1: 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))))
(if (and (stringp result) (search ":LOG" result) (or (search "Failure" result) (search "missing" result)))
(kernel-log "SYSTEM 1: Backend ~a failed. Falling back..." backend)
(return-from ask-neuro result))))))
"(:type :LOG :payload (:text \"Neural Cascade Failure\"))"))
(if *consensus-enabled-p*
;; PARALLEL CONSENSUS MODE
(let ((results nil)
(threads nil)
(lock (bt:make-lock)))
(dolist (backend backends)
(let ((backend-fn (gethash backend *neuro-backends*)))
(when backend-fn
(push (bt:make-thread
(lambda ()
(kernel-log "SYSTEM 1 [Consensus]: Querying backend ~a..." backend)
(let* ((model (when *model-selector-fn* (funcall *model-selector-fn* backend context)))
(result (ignore-errors
(if model
(funcall backend-fn prompt system-prompt :model model)
(funcall backend-fn prompt system-prompt)))))
(bt:with-lock-held (lock)
(push result results)))))
threads))))
;; Wait for all threads with a timeout (e.g., 30s)
(let ((start-time (get-universal-time)))
(loop while (and (< (length results) (length threads))
(< (- (get-universal-time) start-time) 30))
do (sleep 0.1)))
;; Return the list of raw results (filtering out nils or errors)
(let ((valid-results (remove-if-not #'stringp results)))
(if valid-results
(format nil "~{~a~^|CONSENSUS-SEP|~}" valid-results)
"(:type :LOG :payload (:text \"Neural Consensus Failure\"))")))
;; SEQUENTIAL CASCADE MODE (Legacy)
(or (dolist (backend backends)
(let ((backend-fn (gethash backend *neuro-backends*)))
(when backend-fn
(kernel-log "SYSTEM 1: 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))))
(unless (and (stringp result) (search ":LOG" result) (or (search "Failure" result) (search "missing" result)))
(return result))))))
"(:type :LOG :payload (:text \"Neural Cascade Failure\"))"))))
(defun token-accountant-route-task (context)
"Generic fallback for routing. Overridden by skill-token-accountant."
@@ -87,21 +118,24 @@ To call a tool, you MUST use:
")))
(if (and raw-prompt (> (length raw-prompt) 1))
(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))))
(let* ((thought (ask-neuro raw-prompt :system-prompt full-system-prompt :context context))
(raw-thoughts (cl-ppcre:split (cl-ppcre:quote-meta-chars "|CONSENSUS-SEP|") thought))
(suggestions nil))
(dolist (raw-thought raw-thoughts)
(kernel-log "SYSTEM 1 RAW: ~a~%" raw-thought)
(let* ((cleaned-thought
(let ((match (cl-ppcre:scan-to-strings "(?s)```(?:lisp)?\\n?(.*?)\\n?```" raw-thought)))
(if match
(let ((regs (nth-value 1 (cl-ppcre:scan-to-strings "(?s)```(?:lisp)?\\n?(.*?)\\n?```" raw-thought))))
(if (and regs (> (length regs) 0)) (elt regs 0) raw-thought))
(string-trim '(#\Space #\Newline #\Tab) raw-thought))))
(suggestion (ignore-errors (read-from-string cleaned-thought))))
(kernel-log "SYSTEM 1 Suggestion: ~a~%" cleaned-thought)
(when (and suggestion (listp suggestion))
(push suggestion suggestions))))
(if (and *consensus-enabled-p* suggestions)
(nreverse suggestions)
(first (nreverse suggestions))))
'(:type :LOG :payload (:text "Skill triggered (Deterministic only)")))))
nil)))

3
src/package.lisp
View File

@@ -33,6 +33,9 @@
#:rollback-object-store
#:send-swarm-packet
;; --- Self-Fix Agent ---
#:self-fix-apply
;; --- Context API (Peripheral Vision) ---
#:context-query-store
#:context-get-active-projects

42
src/safety-harness.lisp
View File

@@ -40,3 +40,45 @@
declare ignore
;; Let's also add simple data types
t nil quote function))
(defvar *safety-registry* nil
"List of dynamically registered safe symbols.")
(defun safety-harness-register (symbols)
"Adds symbols to the global safety registry."
(setf *safety-registry* (append *safety-registry* (if (listp symbols) symbols (list symbols))))
(kernel-log "SAFETY HARNESS: Registered ~a new safe symbols." (length (if (listp symbols) symbols (list symbols)))))
(defun safety-harness-is-safe (symbol)
"Checks if a symbol is in the static whitelist or the dynamic registry."
(or (member symbol *safety-whitelist* :test #'string-equal)
(member symbol *safety-registry* :test #'string-equal)))
(defun safety-harness-ast-walk (form)
"Recursively walks the Lisp AST. Returns T if safe, NIL if unsafe."
(cond
;; Self-evaluating objects (strings, numbers, keywords) are safe.
((or (stringp form) (numberp form) (keywordp form) (characterp form))
t)
;; Symbols used as variables (in non-function position)
((symbolp form)
(safety-harness-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)
((safety-harness-is-safe head)
(every #'safety-harness-ast-walk (cdr form)))
(t
(kernel-log "SAFETY HARNESS: Blocked call to non-whitelisted function ~a" head)
nil))))
(t nil)))
(defun safety-harness-validate (code)
"Parses and validates a Lisp string or form."
(let ((form (if (stringp code) (ignore-errors (read-from-string code)) code)))
(if form
(safety-harness-ast-walk form)
nil)))

54
src/self-fix.lisp Normal file
View File

@@ -0,0 +1,54 @@
(in-package :org-agent)
(defun self-fix-apply (action context)
"Applies a surgical code fix and reloads the modified skill."
(declare (ignore context))
(let* ((payload (getf action :payload))
(target-file (getf payload :file))
(old-code (getf payload :old))
(new-code (getf payload :new))
(is-skill (and (stringp (namestring target-file))
(search "skills/" (namestring target-file)))))
(snapshot-object-store)
(kernel-log "SELF-FIX - Attempting surgical fix on ~a..." target-file)
(handler-case
(if (uiop:file-exists-p target-file)
(let ((content (uiop:read-file-string target-file)))
(if (search old-code content)
(let ((new-content (cl-ppcre:regex-replace-all (cl-ppcre:quote-meta-chars old-code) content new-code)))
(with-open-file (out target-file :direction :output :if-exists :supersede)
(write-string new-content out))
(if is-skill
(progn
(kernel-log "SELF-FIX - Reloading modified skill ~a..." target-file)
(if (load-skill-from-org target-file)
(progn
(kernel-log "SELF-FIX SUCCESS - Applied and reloaded.")
t)
(progn
(kernel-log "SELF-FIX FAILURE - Skill reload failed. Rolling back.")
(with-open-file (out target-file :direction :output :if-exists :supersede)
(write-string content out))
(rollback-object-store 0)
nil)))
(progn
(kernel-log "SELF-FIX SUCCESS - Applied fix to file.")
t)))
(progn (kernel-log "SELF-FIX FAILURE - Pattern not found.") nil)))
(progn (kernel-log "SELF-FIX FAILURE - File not found.") nil))
(error (c)
(kernel-log "SELF-FIX CRASH - ~a. Rolling back." c)
(rollback-object-store 0)
nil))))
(def-cognitive-tool :repair-file "Applies a surgical code modification to a file and reloads the skill if applicable."
:parameters ((:file :type :string :description "Path to the target file")
(:old :type :string :description "The literal code block to find")
(:new :type :string :description "The literal code block to replace it with"))
:body (lambda (args)
(if (self-fix-apply (list :payload args) nil)
"REPAIR SUCCESSFUL."
"REPAIR FAILED.")))

21
src/symbolic.lisp
View File

@@ -1,7 +1,28 @@
(in-package :org-agent)
(defun task-integrity-check (action)
"Enforces semantic GTD integrity rules on proposed actions."
(let* ((payload (getf action :payload))
(act (or (getf payload :action) (getf action :action)))
(id (or (getf payload :id) (getf action :id)))
(new-attrs (or (getf payload :attributes) (getf action :attributes))))
(when (and (eq act :update-node) (equal (getf new-attrs :TODO) "DONE"))
(let ((children (list-objects-with-attribute :PARENT id)))
(when (some (lambda (child) (let ((todo (getf (org-object-attributes child) :TODO)))
(and todo (not (equal todo "DONE")))))
children)
(return-from task-integrity-check "Blocked by Task Integrity: Active children exist."))))
nil))
(defun decide (proposed-action context)
"The System 2 Safety Gate: validates or rejects proposed neural actions."
;; 1. Task Integrity Check (GTD Semantics)
(let ((integrity-error (task-integrity-check proposed-action)))
(when integrity-error
(kernel-log "SYSTEM 2 [INTEGRITY]: ~a~%" integrity-error)
(return-from decide (list :type :LOG :payload (list :text integrity-error)))))
;; 2. Skill-specific and Safety Checks
(let ((active-skill (find-triggered-skill context)))
(if (and proposed-action (listp proposed-action) active-skill)
(let* ((symbolic-gate (skill-symbolic-fn active-skill))