(in-package :passepartout) (defvar *VAULT-MEMORY* (make-hash-table :test 'equal)) (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)))))))) (defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn) (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.") (defvar *standing-mandates* nil "List of functions (context) → string-or-nil. Each is called on every think() cycle. When non-nil, the returned string is injected into the IDENTITY section of the system prompt. Unlike skills (which activate on triggers), standing mandates are always consulted.") (defstruct skill-entry filename (status :discovered) error-log (load-time 0)) ;; Alias: find-triggered-skill → skill-triggered-find (defun find-triggered-skill (context) (skill-triggered-find context)) (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) "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))) (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-package") (string= n "core-skills") (string= n "core-transport") (string= n "core-memory") (string= n "core-context") (string= n "core-perceive") (string= n "core-reason") (string= n "core-act") (string= n "core-pipeline") (string= n "core-manifest") (string= n "neuro-router") (string= n "neuro-explorer") (string= n "channel-tui")))) 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 :passepartout) forms only — preserves test-package declarations so embedded test code evaluates in the correct package." (let ((lines (uiop:split-string code-string :separator '(#\Newline))) (result "")) (dolist (line lines) (let ((trimmed (string-trim '(#\Space #\Tab) line))) (if (uiop:string-prefix-p "(in-package :passepartout)" trimmed) (setf result (concatenate 'string result (string #\Newline))) (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)) (exported 0) (seen (make-hash-table :test 'equal))) (do-symbols (sym (find-package pkg-name)) (when (and (eq (symbol-package sym) (find-package pkg-name)) (or (fboundp sym) (boundp sym)) (not (gethash (symbol-name sym) seen))) (setf (gethash (symbol-name sym) seen) t) (incf exported) (let ((existing (find-symbol (symbol-name sym) target-pkg))) (when existing (unintern existing target-pkg))) (import sym target-pkg) (export sym target-pkg))) (log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT" exported (package-name (find-package pkg-name)))) (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* ((jailed-pkg (find-package pkg-name)) (restricted '("RUN-PROGRAM" "SHELL" "RUN-SHELL-COMMAND")) (violation (loop for r in restricted for sym = (find-symbol r :uiop) when (and sym (fboundp sym) (loop for skill-sym being the symbols of jailed-pkg when (and (fboundp skill-sym) (eq (symbol-function skill-sym) (symbol-function sym))) return skill-sym)) collect (format nil "~a" sym)))) (when violation (log-message "LOADER SANDBOX: Skill '~a' blocked — references restricted symbol(s): ~{~a~^, ~}" skill-base-name violation) (setf (skill-entry-status entry) :sandbox-blocked) (return-from load-skill-from-lisp nil)) (log-message "LOADER SANDBOX: Skill '~a' passed sandbox check" skill-base-name)) (let ((target-pkg (find-package :passepartout)) (exported 0) (seen (make-hash-table :test 'equal))) (do-symbols (sym (find-package pkg-name)) (when (and (eq (symbol-package sym) (find-package pkg-name)) (or (fboundp sym) (boundp sym)) (not (gethash (symbol-name sym) seen))) (setf (gethash (symbol-name sym) seen) t) (incf exported) (let ((existing (find-symbol (symbol-name sym) target-pkg))) (when existing (unintern existing target-pkg))) (import sym target-pkg) (ignore-errors (export sym target-pkg)))) (log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT" exported (package-name (find-package pkg-name)))) (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.")))) (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :fiveam :silent t)) (defpackage :passepartout-boot-tests (:use :cl :fiveam :passepartout) (:export #:boot-suite)) (in-package :passepartout-boot-tests) (def-suite boot-suite :description "Verification of the Skill Engine loader") (in-suite boot-suite) (test test-topological-sort-basic "Contract 2: dependency ordering puts dependencies before dependents." (let ((tmp-dir "/tmp/passepartout-boot-test/")) (uiop:ensure-all-directories-exist (list tmp-dir)) (with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede) (format out "#+DEPENDS_ON: skill-b-id~%")) (with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede) (format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%")) (unwind-protect (let ((sorted (passepartout::skill-topological-sort tmp-dir))) (let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal)) (pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal))) (is (< pos-b pos-a)))) (uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t)))) (test test-lisp-syntax-validate-valid "Contract 1: valid Lisp code passes syntax validation." (is (eq t (lisp-syntax-validate "(+ 1 2)")))) (test test-lisp-syntax-validate-invalid "Contract 1: unbalanced Lisp code fails syntax validation." (is (null (lisp-syntax-validate "(+ 1 2"))))