(in-package :opencortex) (defun 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)))))))) ;; TODO: Stub for vault - implement later (defun VAULT-MASK-STRING (s) "[MASKED]") (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 from org file." (let ((dependencies nil) (id nil) (content (uiop:read-file-string filepath))) ;; Simple ID extraction using string search (let ((id-start (search ":ID:" content))) (when id-start (let ((id-end (position #\Newline content :start id-start))) (when id-end (setf id (string-trim " " (subseq content (+ id-start 4) id-end))))))) ;; Simple DEPENDS_ON extraction (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 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-utils-validate) (lisp-utils-validate code-string :strict nil) (handler-case (let ((*read-eval* nil)) (with-input-from-string (stream (format nil "(progn ~a)" code-string)) (loop for form = (read stream nil :eof) until (eq form :eof))) (list :status :success)) (error (c) (list :status :error :reason (format nil "~a" c))))))) (if (eq (getf result :status) :success) (values t nil) (values nil (or (getf result :reason) "Lisp Validator rejected code."))))) (defun extract-tangle-target (line) "Extracts the value of the :tangle header from an org src block line. Handles both simple strings and parenthesized elisp expressions." (let ((pos (search ":tangle" line))) (when pos (let ((rest (string-trim '(#\Space #\Tab) (subseq line (+ pos 7))))) (if (char= (char rest 0) #\() ;; It's an elisp expression, find the matching closing paren (let ((balance 0) (end nil)) (dotimes (i (length rest)) (let ((ch (char rest i))) (cond ((char= ch #\() (incf balance)) ((char= ch #\)) (decf balance))) (when (and (> i 0) (= balance 0)) (setf end (1+ i)) (return-from extract-tangle-target (subseq rest 0 end))))) rest) ;; It's a simple string, stop at next space (let ((end (position #\Space rest))) (if end (subseq rest 0 end) rest))))))) (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" clean-line) (setf in-lisp-block t) (let ((tangle-target (extract-tangle-target clean-line))) (if (or (and tangle-target (not (search "/tests" tangle-target)) (not (search ":tangle no" clean-line))) (and (not tangle-target) (not (search ":tangle no" clean-line)))) (setf collect-this-block t) (setf collect-this-block nil)))) ((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))) (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)))) ;; Export symbols back to :OPENCORTEX for discoverability and testing (let* ((target-pkg (find-package :opencortex)) (raw-name (string-upcase skill-base-name)) (short-name (if (uiop:string-prefix-p "ORG-SKILL-" raw-name) (subseq raw-name 10) raw-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)) (harness-log "LOADER: Exporting ~a to :OPENCORTEX" sn) ;; Resolve potential name conflicts by uninterning first (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) (let ((msg (format nil "~a" c))) (harness-log "LOADER ERROR in skill '~a': ~a" skill-base-name msg) (setf (skill-entry-status entry) :failed) (setf (skill-entry-error-log entry) msg) nil))))) (defun load-skill-with-timeout (filepath timeout-seconds) "Loads a skill Org file with a hard execution timeout." (let* ((finished nil) (thread (bt:make-thread (lambda () (if (load-skill-from-org filepath) (setf finished t) (setf finished :error))))) (start-time (get-internal-real-time)) (timeout-units (truncate (* timeout-seconds internal-time-units-per-second)))) (loop (when (eq finished t) (return :success)) (when (eq finished :error) (return :error)) (unless (bt:thread-alive-p thread) (return :error)) (when (> (- (get-internal-real-time) start-time) timeout-units) (harness-log "HARNESS: Timing out skill ~a..." (pathname-name filepath)) #+sbcl (sb-thread:terminate-thread thread) #-sbcl (bt:destroy-thread thread) (return :timeout)) (sleep 0.05)))) (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 :args (...)) EXAMPLES: (:target :tool :action :call :tool \"eval\" :args (:code \"(+ 1 1)\")) (:target :tool :action :call :tool \"grep-search\" :args (:pattern \"autonomousty\")) (:target :tool :action :call :tool \"shell\" :args (:cmd \"ls -la\")) --- " ))) (maphash (lambda (name tool) (let ((perm (ignore-errors (uiop:symbol-call :opencortex.skills.org-skill-tool-permissions :get-tool-permission name)))) (unless (eq perm :deny) (setf output (concatenate 'string output (format nil "- ~a: ~a~% Parameters: ~s~%~%" name (cognitive-tool-description tool) (cognitive-tool-parameters tool))))))) *cognitive-tools*) output)) (def-cognitive-tool :grep-search "Searches for a pattern in the project files." ((:pattern :type :string :description "The regex pattern to search for") (:dir :type :string :description "Directory to search in (default is project root)")) :body (lambda (args) (let ((pattern (getf args :pattern)) (dir (or (getf args :dir) (uiop:getenv "MEMEX_DIR")))) (uiop:run-program (list "grep" "-r" "-n" "--exclude-dir=node_modules" pattern dir) :output :string :ignore-error-status t)))) (def-cognitive-tool :shell "Executes a shell command on the local machine. Use this for file operations, system checks, or running tests." ((:cmd :type :string :description "The full bash command to execute")) :guard (lambda (args context) (declare (ignore context)) (let ((cmd (getf args :cmd))) (not (or (search "rm -rf /" cmd) (search ":(){ :|:& };:" cmd))))) :body (lambda (args) (let ((cmd (getf args :cmd))) (multiple-value-bind (out err code) (uiop:run-program (list "bash" "-c" cmd) :output :string :error-output :string :ignore-error-status t) (format nil "EXIT-CODE: ~a~%~%STDOUT:~%~a~%~%STDERR:~%~a" code out err))))) (def-cognitive-tool :reload-skill "Reloads a skill from its Org-mode source file, recompiling into the live image without restarting the daemon." ((:skill :type :string :description "The skill name (e.g., \"org-skill-policy\") or full path to the .org file")) :guard (lambda (args context) (declare (ignore context)) (let ((skill (getf args :skill))) (or (uiop:file-exists-p skill) (let ((skills-dir (or (ignore-errors (uiop:getenv "SKILLS_DIR")) (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))) (uiop:file-exists-p (merge-pathnames (format nil "~a.org" skill) skills-dir)))))) :body (lambda (args) (let ((skill (getf args :skill))) (snapshot-memory) (let ((skills-dir (or (ignore-errors (uiop:getenv "SKILLS_DIR")) (namestring (merge-pathnames "notes/" (user-homedir-pathname))))) (resolved-path (context-resolve-path skills-dir)) (skills-dir-actual (if (ignore-errors (uiop:getenv "SKILLS_DIR")) (uiop:ensure-directory-pathname (context-resolve-path (uiop:getenv "SKILLS_DIR"))) (uiop:ensure-directory-pathname (user-homedir-pathname))))) (let ((file (if (uiop:file-exists-p skill) (uiop:ensure-pathname skill) (merge-pathnames (format nil "~a.org" skill) skills-dir-actual)))) (cond ((not (uiop:file-exists-p file)) (format nil "ERROR: Skill file not found: ~a" (uiop:native-namestring file))) (t (harness-log "SKILL: Hot-reloading ~a..." (pathname-name file)) (let ((status (load-skill-with-timeout file 10))) (if (eq status :success) (let ((base-name (pathname-name file))) (setf (skill-entry-status (gethash base-name *skill-catalog*)) :ready) (format nil "OK: Skill '~a' reloaded successfully." base-name)) (format nil "ERROR: Reload failed with status ~a" status)))))))))) (def-cognitive-tool :read-file "Reads the contents of a file as a string." ((:file :type :string :description "The path to the file to read")) :guard (lambda (args context) (declare (ignore context)) (let* ((file (getf args :file)) (memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex")) (abs-path (namestring (uiop:ensure-absolute-pathname file (uiop:getcwd))))) (and (str:starts-with-p memex-root abs-path) (not (search ".." abs-path))))) :body (lambda (args) (let ((file (getf args :file))) (handler-case (uiop:read-file-string file) (error (c) (format nil "ERROR reading ~a: ~a" file c)))))) (def-cognitive-tool :write-file "Writes content to a file, creating it if it doesn't exist." ((:file :type :string :description "The path to the file to write") (:content :type :string :description "The content to write") (:append :type :string :description "\"t\" to append instead of overwriting (optional)")) :guard (lambda (args context) (declare (ignore context)) (let* ((file (getf args :file)) (memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex")) (abs-path (namestring (uiop:ensure-absolute-pathname file (uiop:getcwd))))) (and (str:starts-with-p memex-root abs-path) (not (search ".." abs-path)) (not (str:ends-with-p ".org" abs-path))))) ;; Force AST tools for .org files :body (lambda (args) (let ((file (getf args :file)) (content (getf args :content)) (append-p (string-equal (getf args :append) "t"))) (handler-case (progn (snapshot-memory) (with-open-file (out file :direction :output :if-exists (if append-p :append :supersede) :if-does-not-exist :create) (write-string content out)) (format nil "OK: ~a written to ~a" (if append-p "content appended" "file written") file)) (error (c) (format nil "ERROR writing ~a: ~a" file c)))))) (def-cognitive-tool :replace-string "Replaces occurrences of old-string with new-string in a file." ((:file :type :string :description "The path to the file") (:old :type :string :description "The substring to find and replace") (:new :type :string :description "The replacement string")) :guard (lambda (args context) (declare (ignore context)) (let* ((file (getf args :file)) (memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex")) (abs-path (namestring (uiop:ensure-absolute-pathname file (uiop:getcwd))))) (and (str:starts-with-p memex-root abs-path) (not (search ".." abs-path)) (not (str:ends-with-p ".org" abs-path))))) ;; Force AST tools for .org files :body (lambda (args) (let ((file (getf args :file)) (old (getf args :old)) (new (getf args :new))) (handler-case (progn (snapshot-memory) (let ((content (uiop:read-file-string file))) (if (search old content) (let ((new-content (cl-ppcre:regex-replace-all (cl-ppcre:quote-meta-chars old) content new))) (with-open-file (out file :direction :output :if-exists :supersede) (write-string new-content out)) (format nil "OK: Replaced first occurrence in ~a" file)) (format nil "ERROR: Pattern not found in ~a" file)))) (error (c) (format nil "ERROR replacing in ~a: ~a" file c))))))