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

rename gateway-* → system-model-* + gateway-messaging, de-ollama, add system-model-explorer

Browse Source 
- Rename gateway-provider → system-model-provider (generic :local provider, no hardcoded ollama)
- Rename gateway-llm → system-model (model-request dispatcher)
- Rename system-embedding-gateway → system-model-embedding
- Rename gateway-manager → gateway-messaging (public api renamed to messaging-*)
- Add system-model-explorer (model discovery via OpenRouter API, cached, per-slot recommendations)
- Fix skill loader export: replace prefix-matching with fbound/boundp-based export (20 skills now export)
- Add model-router to skill-loader exclusion list (loaded via CLI)
- De-ollama: remove hardcoded assumed-available patterns from provider pipeline
- Default cascade: cloud-only (openrouter, openai, groq, gemini, deepseek, nvidia, anthropic)
- Env example: add LOCAL_BASE_URL, fix cascade order
- All org files updated with architectural prose (literate programming)
This commit is contained in:
Amr Gharbeia
2026-05-04 09:58:59 -04:00
parent 7dad50910f
commit 908936d4d3
32 changed files with 889 additions and 919 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
lisp/core-communication.lisp
View File

@@ -113,6 +113,10 @@
(error "Invalid message type '~a'" type))
t))
(defun validate-communication-protocol-schema (msg)
"Backward-compatibility alias for protocol-schema-validate."
(protocol-schema-validate msg))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))

4
lisp/core-defpackage.lisp
View File

@@ -24,7 +24,9 @@
#:run-setup-wizard
#:skill-gateway-register
#:skill-gateway-link
#:gateway-manager-main
#:messaging-list-print
#:messaging-link
#:messaging-unlink
#:ingest-ast
#:memory-object-get
#:list-objects-by-type

114
lisp/core-loop-reason.lisp
View File

@@ -1,5 +1,12 @@
(in-package :passepartout)
(defvar *probabilistic-backends* (make-hash-table :test 'equal)
"Maps provider keyword → handler function (prompt system-prompt &key model).")
(defun register-probabilistic-backend (name fn)
"Register FN as the handler for provider NAME."
(setf (gethash name *probabilistic-backends*) fn))
(defvar *backend-registry* (make-hash-table :test 'equal))
(defvar *provider-cascade* nil)
@@ -15,30 +22,33 @@
(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-val (when *model-selector*
(funcall *model-selector* backend context))))
(if (eq model-val :skip)
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend)
(let* ((model (if model-val model-val nil))
(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)
(let ((backends (or cascade *provider-cascade*))
(result nil))
(dolist (backend backends (or result
(list :type :LOG
:payload (list :text "Neural Cascade Failure: All providers exhausted."))))
(let ((backend-fn (or (gethash backend *backend-registry*)
(gethash backend *probabilistic-backends*))))
(when backend-fn
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
(let* ((model (and *model-selector*
(funcall *model-selector* backend context)))
(skip (eq model :skip))
(r (unless skip
(if (and model (not skip))
(funcall backend-fn prompt system-prompt :model model)
(funcall backend-fn prompt system-prompt)))))
(when skip
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend))
(cond ((and (listp r) (eq (getf r :status) :success))
(setf result (getf r :content))
(return result))
((stringp r)
(setf result r)
(return result))
(t
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
backend (getf r :message))))))))))(defun markdown-strip (text)
(if (and text (stringp text))
(let ((cleaned text))
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
@@ -84,40 +94,52 @@
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)))
(cleaned (if (and (listp thought) (getf thought :type))
(format nil "~a" (getf (getf thought :payload) :text))
(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."))))
(let ((parsed (read-from-string cleaned)))
(if (listp parsed)
(let ((normalized (plist-keywords-normalize parsed)))
;; Ensure explanation is present in the payload for policy gate
(let ((payload (proto-get normalized :payload)))
(if (and payload (proto-get payload :explanation))
normalized
(let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine."
(if (listp payload) payload nil))))
(list* :PAYLOAD new-payload
(loop for (k v) on normalized by #'cddr
unless (eq k :PAYLOAD)
collect k collect v))))))
(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)
"Runs all registered deterministic gates against the proposed action.
Returns either a rejection plist (for :LOG or :EVENT errors) or the
modified action (for approval-required or pass)."
"Runs all registered deterministic gates against the proposed action,
sorted by priority (highest first). Returns a rejection plist or the action."
(let ((current-action (copy-tree proposed-action))
(approval-needed nil)
(approval-action nil))
(approval-action nil)
(gates nil))
;; Collect gates sorted by priority (highest first)
(maphash (lambda (name skill)
(declare (ignore name))
(when (skill-deterministic-fn skill)
(let ((gate (skill-deterministic-fn skill)))
(when gate
(let ((result (funcall gate current-action context)))
(cond
;; Approval-required: remember it and continue checking
((eq (getf result :level) :approval-required)
(setf approval-needed t
approval-action (getf (getf result :payload) :action)))
;; Hard rejection: return immediately
((member (getf result :type) '(:LOG :EVENT))
(return-from cognitive-verify result))
;; Normal: update action
(t (setf current-action result))))))))
(push (cons (skill-priority skill) (skill-deterministic-fn skill)) gates)))
*skill-registry*)
(setf gates (sort gates #'> :key #'car))
(dolist (gate-pair gates)
(let ((result (funcall (cdr gate-pair) current-action context)))
(cond
((eq (getf result :level) :approval-required)
(setf approval-needed t
approval-action (getf (getf result :payload) :action)))
((member (getf result :type) '(:LOG :EVENT))
(return-from cognitive-verify result))
((and (listp result) result)
(setf current-action result)))))
(if approval-needed
(list :type :EVENT :level :approval-required
:payload (list :sensor :approval-required

72
lisp/core-skills.lisp
View File

@@ -97,7 +97,9 @@
(string= n "core-loop")
(string= n "core-manifest")
(string= n "security-dispatcher")
(string= n "system-embedding-gateway"))))
(string= n "system-model-router")
(string= n "system-model-embedding")
(string= n "system-model-explorer"))))
all-files))
(adj (make-hash-table :test 'equal))
(name-to-file (make-hash-table :test 'equal))
@@ -206,26 +208,22 @@
(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)))
(let ((target-pkg (find-package :passepartout))
(exported 0)
(seen (make-hash-table :test 'equal)))
(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))))))
(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 (and existing (not (eq existing sym)))
(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)
@@ -251,26 +249,22 @@
(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)))
(let ((target-pkg (find-package :passepartout))
(exported 0)
(seen (make-hash-table :test 'equal)))
(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))))))
(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 (and existing (not (eq existing sym)))
(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))
(error (c)
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)

43
lisp/gateway-llm.lisp
View File

@@ -1,43 +0,0 @@
(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 "GATEWAY-LLM-REQUEST" :passepartout.gateway-llm)
(find-symbol "GATEWAY-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")))))

60
lisp/gateway-manager.lisp → lisp/gateway-messaging.lisp
View File

@@ -1,8 +1,8 @@
(defvar *gateway-configs* (make-hash-table :test 'equal)
"Maps platform name → plist (:token :thread :interval :enabled)")
"Maps platform name to plist (:token :thread :interval :enabled)")
(defvar *gateway-registry* (make-hash-table :test 'equal)
"Maps platform name → plist (:poll-fn :send-fn :default-interval)")
"Maps platform name to plist (:poll-fn :send-fn :default-interval)")
(defun telegram-get-token ()
(vault-get-secret :telegram))
@@ -25,14 +25,14 @@
(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)
(unless (ignore-errors (hitl-handle-message text :telegram))
(stimulus-inject
(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))))))
(when (and text chat-id)
(log-message "TELEGRAM: Received message from ~a" chat-id)
(unless (ignore-errors (hitl-handle-message text :telegram))
(stimulus-inject
(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."
@@ -43,7 +43,6 @@
(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
@@ -62,7 +61,7 @@
(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)))
(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)))
@@ -70,13 +69,13 @@
(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)
(unless (ignore-errors (hitl-handle-message text :signal))
(stimulus-inject
(list :type :EVENT
:meta (list :source :signal :chat-id source)
:payload (list :sensor :user-input :text text))))))))
(when (and source text)
(log-message "SIGNAL: Received message from ~a" source)
(unless (ignore-errors (hitl-handle-message text :signal))
(stimulus-inject
(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)
@@ -88,7 +87,6 @@
(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)
@@ -117,7 +115,7 @@
(getf config :thread)
(bt:thread-alive-p (getf config :thread)))))
(defun gateway-link (platform token)
(defun messaging-link (platform token)
"Links a platform with a token and starts polling."
(let ((platform-lc (string-downcase platform)))
(unless (gethash platform-lc *gateway-registry*)
@@ -125,7 +123,7 @@
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)
(log-message "MESSAGING: 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)))
@@ -133,16 +131,16 @@
(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)
(log-message "MESSAGING: Successfully linked ~a" platform-lc)
(format t "Successfully linked ~a gateway. Token stored securely.~%" platform-lc)
t)))
(defun gateway-unlink (platform)
(defun messaging-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)
(log-message "MESSAGING: Unlinked ~a" platform-lc)
(format t "Successfully unlinked ~a gateway.~%" platform-lc)
t))
@@ -162,7 +160,7 @@
(funcall poll-fn))
(sleep interval)))
:name (format nil "passepartout-~a-gateway" platform-lc)))
(log-message "GATEWAY: Started ~a polling (interval: ~as)" platform-lc interval)))))))))
(log-message "MESSAGING: Started ~a polling (interval: ~as)" platform-lc interval))))))))
(defun gateway-stop (platform)
"Stops the polling thread for a gateway."
@@ -170,11 +168,11 @@
(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)
(log-message "MESSAGING: Stopping ~a polling thread" platform-lc)
(bt:destroy-thread (getf config :thread))))
(setf (getf config :thread) nil))))
(defun gateway-list ()
(defun messaging-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))
@@ -183,11 +181,11 @@
:configured configured
:active active))))
(defun gateway-list-print ()
(defun messaging-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))
(dolist (gw (messaging-list))
(format t " ~20@A ~12@A ~10@A~%"
(getf gw :platform)
(if (getf gw :configured) "yes" "no")
@@ -208,7 +206,7 @@
(register-actuator :telegram #'telegram-send)
(register-actuator :signal #'signal-send)
(defskill :passepartout-gateway-manager
(defskill :passepartout-gateway-messaging
:priority 150
:trigger (lambda (ctx) (declare (ignore ctx)) nil))

4
lisp/system-archivist.lisp
View File

@@ -213,10 +213,10 @@ Returns a list of link target strings."
(pushnew target links :test #'string=)))
links))
(defun archivist-run (context)
(defun archivist-run (action context)
"Runs the archivist maintenance cycle. Checks Scribe and Gardener schedules
and dispatches as needed. Called by the deterministic gate."
(declare (ignore context))
(declare (ignore action context))
(let ((now (get-universal-time)))
;; Scribe runs every 6 hours (21600 seconds)
(when (>= (- now *archivist-last-scribe*) 21600)

123
lisp/system-embedding-gateway.lisp
View File

@@ -1,123 +0,0 @@
(in-package :passepartout)
(defvar *embedding-queue* nil
"List of object IDs pending embedding.")
(defvar *embedding-provider* :hashing
"Active embedding provider: :hashing, :ollama, :openai.")
(defun embeddings-tokenize (text)
"Split TEXT into lowercase word tokens, strip punctuation, discard short."
(let ((clean (cl-ppcre:regex-replace-all "[^a-zA-Z0-9 ]"
(string-downcase (or text "")) " ")))
(remove-if (lambda (w) (< (length w) 2))
(uiop:split-string clean :separator '(#\Space #\Tab #\Newline)))))
(defun embeddings-hash-word (word dim)
"Hash WORD to an index in [0, DIM)."
(let ((hash 2166136261))
(loop for c across word
do (setf hash (logxor hash (char-code c)))
(setf hash (mod (* hash 16777619) #x100000000)))
(mod hash dim)))
(defun embeddings-hash-vector (text &key (dimensions 384))
"Compute a hashing-trick vector for TEXT."
(let* ((tokens (embeddings-tokenize text))
(vec (make-array dimensions :initial-element 0.0d0 :element-type 'double-float)))
(dolist (token tokens)
(let* ((idx (embeddings-hash-word token dimensions))
(sign (if (evenp (char-code (char token 0))) 1 -1)))
(incf (aref vec idx) (coerce sign 'double-float))))
(let ((norm (sqrt (loop for i below dimensions sum (expt (aref vec i) 2)))))
(if (> norm 0.0d0)
(loop for i below dimensions collect (/ (aref vec i) norm))
(loop for i below dimensions collect 0.0d0)))))
(defun embeddings-compute (text &key (dimensions 384))
"Compute embedding vector for TEXT.
Tries *embedding-backend* first, falls back to hashing trick."
(when *embedding-backend*
(handler-case
(let ((result (funcall *embedding-backend* text)))
(when (and result (listp result) (> (length result) 0))
(return-from embeddings-compute result)))
(error (c)
(log-message "EMBEDDING: Backend failed (~a), fallback to hashing" c))))
(embeddings-hash-vector text :dimensions dimensions))
(defun embedding-backend-ollama (text)
"Generate embeddings via Ollama /api/embeddings."
(let* ((url (or (uiop:getenv "OLLAMA_URL") "http://localhost:11434"))
(model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text"))
(response (dex:post (format nil "~a/api/embeddings" url)
:content (json:encode-json-to-string
`((:model . ,model) (:prompt . ,text)))
:headers '(("Content-Type" . "application/json")))))
(when response
(let* ((json (json:decode-json-from-string response))
(embedding (cdr (assoc :embedding json))))
(when embedding
(coerce embedding 'list))))))
(defun embed-queue-object (obj)
"Queue OBJ for embedding if it lacks a vector."
(when (and obj (not (memory-object-vector obj)))
(pushnew (memory-object-id obj) *embedding-queue* :test 'string=)))
(defun embed-object (obj)
"Generate and store embedding vector for OBJ."
(let* ((attrs (memory-object-attributes obj))
(title (or (getf attrs :TITLE) ""))
(text (or (memory-object-content obj) ""))
(raw-tags (getf attrs :TAGS))
(tag-list (if (listp raw-tags) raw-tags nil))
(tags (if tag-list (format nil "~{~a~^ ~}" tag-list) ""))
(combined (format nil "~a ~a ~a" title text tags))
(vec (embeddings-compute combined)))
(setf (memory-object-vector obj) vec)
(log-message "EMBEDDING: Vector for ~a (~d dims)" (memory-object-id obj) (length vec))
vec))
(defun embed-all-pending ()
"Process all pending embeddings. Returns count."
(let ((count 0))
;; Drain queue
(let ((pending *embedding-queue*))
(setf *embedding-queue* nil)
(dolist (id pending)
(let ((obj (gethash id *memory-store*)))
(when (and obj (not (memory-object-vector obj)))
(handler-case
(progn (embed-object obj) (incf count))
(error (c)
(log-message "EMBEDDING: Failed ~a: ~a" id c)))))))
;; Fallback: scan store for objects without vectors
(when (= count 0)
(maphash (lambda (id obj)
(declare (ignore id))
(unless (memory-object-vector obj)
(handler-case
(progn (embed-object obj) (incf count))
(error (c)
(log-message "EMBEDDING: Failed ~a: ~a"
(memory-object-id obj) c)))))
*memory-store*))
(when (> count 0)
(log-message "EMBEDDING: Batch processed ~d objects" count))
count))
(defun embeddings-init (&key (provider *embedding-provider*))
"Init embedding provider from EMBEDDING_PROVIDER env var."
(let* ((env (uiop:getenv "EMBEDDING_PROVIDER"))
(selected (or (and env (intern (string-upcase env) :keyword))
provider)))
(setf *embedding-provider* selected)
(setf *embedding-backend*
(case selected
(:ollama #'embedding-backend-ollama)
(t nil)))
(log-message "EMBEDDING: Provider ~a, backend=~a" selected *embedding-backend*)
selected))
(embeddings-init)

87
lisp/system-model-embedding.lisp Normal file
View File

@@ -0,0 +1,87 @@
(in-package :passepartout)
(defvar *embedding-provider* :hashing
"Active embedding provider: :hashing, :local, :openai.")
(defvar *embedding-queue* nil
"Queue of text objects awaiting embedding.")
(defvar *embedding-batch-size* 10
"Maximum texts per embedding API call.")
(defun embedding-backend-local (text)
"Generate embeddings via a local OpenAI-compatible endpoint."
(let* ((url (or (uiop:getenv "LOCAL_BASE_URL") (format nil "http://~a" (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))))
(model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text"))
(body (cl-json:encode-json-to-string
`((model . ,model) (input . ,text)))))
(handler-case
(let* ((response (dex:post (format nil "~a/api/embeddings" url)
:headers '(("Content-Type" . "application/json"))
:content body :connect-timeout 5 :read-timeout 30))
(json (cl-json:decode-json-from-string response))
(data (car (cdr (assoc :data json)))))
(or (cdr (assoc :embedding data))
(list :error "No embedding in response")))
(error (c)
(list :error (format nil "Embedding failed: ~a" c))))))
(defun embedding-backend-openai (text)
"Generate embeddings via OpenAI compatible /v1/embeddings endpoint."
(let* ((api-key (uiop:getenv "OPENAI_API_KEY"))
(base-url (or (uiop:getenv "EMBEDDING_BASE_URL") "https://api.openai.com/v1"))
(model (or (uiop:getenv "EMBEDDING_MODEL") "text-embedding-3-small"))
(body (cl-json:encode-json-to-string
`((model . ,model) (input . ,text)))))
(handler-case
(let* ((response (dex:post (format nil "~a/embeddings" base-url)
:headers `(("Content-Type" . "application/json")
("Authorization" . ,(format nil "Bearer ~a" api-key)))
:content body :connect-timeout 5 :read-timeout 30))
(json (cl-json:decode-json-from-string response))
(data (car (cdr (assoc :data json)))))
(or (cdr (assoc :embedding data))
(list :error "No embedding in response")))
(error (c)
(list :error (format nil "OpenAI Embedding failed: ~a" c))))))
(defun embedding-backend-hashing (text)
"Fallback: produces a deterministic vector from the text hash."
(let* ((digest (ironclad:digest-sequence :sha256 (babel:string-to-octets text)))
(vec (make-array 8 :element-type 'single-float :initial-element 0.0)))
(dotimes (i (min (length digest) 8))
(setf (aref vec i) (float (/ (aref digest i) 255.0) 0.0)))
vec))
(defun embed-object (text)
"Embed a single text string using the active backend."
(let* ((selected (or *embedding-provider* :hashing))
(backend (case selected
(:local #'embedding-backend-local)
(:openai #'embedding-backend-openai)
(t #'embedding-backend-hashing))))
(if backend
(progn
(log-message "EMBEDDING: Provider ~a, backend=~a" selected backend)
(funcall backend text))
(progn
(log-message "EMBEDDING: No backend for provider ~a, using hashing" selected)
(embedding-backend-hashing text)))))
(defun embed-queue-object (object)
"Queue a text object for async embedding."
(push object *embedding-queue*)
(log-message "EMBEDDING: Queued object"))
(defun embed-all-pending ()
"Drain the embedding queue, batch-process all queued objects."
(let ((batch (nreverse *embedding-queue*)))
(setf *embedding-queue* nil)
(dolist (item batch)
(handler-case
(let ((text (if (stringp item) item (format nil "~a" item))))
(embed-object text))
(error (c)
(log-message "EMBEDDING: Failed to embed object: ~a" c))))))
(log-message "EMBEDDING: Gateway loaded with provider ~a" *embedding-provider*)

63
lisp/system-model-explorer.lisp Normal file
View File

@@ -0,0 +1,63 @@
(in-package :passepartout)
(defvar *model-cache* (make-hash-table :test 'equal)
"Cache: provider keyword -> (timestamp . model-list)")
(defvar *model-cache-ttl* 300
"Cache TTL in seconds (default 5 min)")
(defun model-explorer-fetch-openrouter ()
"Query OpenRouter /api/v1/models and return parsed model list."
(handler-case
(let* ((raw (dex:get "https://openrouter.ai/api/v1/models" :connect-timeout 10 :read-timeout 20))
(json (cl-json:decode-json-from-string raw))
(data (cdr (assoc :data json))))
(mapcar (lambda (m)
(let ((pricing (cdr (assoc :pricing m))))
(list :id (cdr (assoc :id m))
:name (cdr (assoc :name m))
:context (cdr (assoc :context_length m))
:free (and pricing
(string= "0" (cdr (assoc :prompt pricing)))
(string= "0" (cdr (assoc :completion pricing)))))))
data))
(error (c)
(log-message "MODEL-EXPLORER: OpenRouter API error: ~a" c)
nil)))
(defun model-explorer-fetch (provider)
"Fetch available models for PROVIDER. Returns list of (:id :name :context :free) plists."
(let ((cached (gethash provider *model-cache*)))
(when (and cached (< (- (get-universal-time) (car cached)) *model-cache-ttl*))
(return-from model-explorer-fetch (cdr cached))))
(let ((models (case provider
(:openrouter (model-explorer-fetch-openrouter))
(t nil))))
(when models
(setf (gethash provider *model-cache*)
(cons (get-universal-time) models)))
models))
(defun model-explorer-list-free ()
"Return all free models from cache or fetch."
(remove-if-not (lambda (m) (getf m :free)) (model-explorer-fetch :openrouter)))
(defun model-explorer-recommend (slot)
"Return recommended models for SLOT (:code, :chat, :plan, :background)."
(case slot
(:code
'((:id "qwen/qwen3-coder:free" :name "Qwen3 Coder 480B" :context 262000 :free t :note "Top-tier code MoE, 35B active")
(:id "poolside/laguna-m.1:free" :name "Laguna M.1" :context 131072 :free t :note "Flagship coding agent")
(:id "openai/gpt-oss-120b:free" :name "gpt-oss-120b" :context 131072 :free t :note "117B MoE open-weight coding")))
(:plan
'((:id "openrouter/owl-alpha" :name "Owl Alpha" :context 1048756 :free t :note "Agentic, tool use, reasoning")
(:id "nousresearch/hermes-3-llama-3.1-405b:free" :name "Hermes 3 405B" :context 131072 :free t :note "405B generalist, strong planning")
(:id "minimax/minimax-m2.5:free" :name "MiniMax M2.5" :context 196608 :free t :note "SOTA productivity, long context")))
(:chat
'((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Strong multilingual generalist")
(:id "google/gemma-4-31b-it:free" :name "Gemma 4 31B" :context 262144 :free t :note "Dense 31B, thinking mode, long context")
(:id "mistralai/mistral-nemo:free" :name "Mistral Nemo" :context 32768 :free t :note "Fast, good for casual conversation")))
(:background
'((:id "meta-llama/llama-3.2-3b-instruct:free" :name "Llama 3.2 3B" :context 131072 :free t :note "Small, fast, efficient")
(:id "liquid/lfm-2.5-1.2b-instruct:free" :name "LFM 2.5 1.2B" :context 32768 :free t :note "Ultra-compact, edge-ready")))
(t '((:id "meta-llama/llama-3.3-70b-instruct:free" :name "Llama 3.3 70B" :context 65536 :free t :note "Safe fallback")))))

28
lisp/gateway-provider.lisp → lisp/system-model-provider.lisp
View File

@@ -1,36 +1,42 @@
(defparameter *provider-configs*
'((:ollama . (:base-url nil :key-env nil :default-model "llama3"))
'((:local . (:base-url nil :key-env nil :url-env "LOCAL_BASE_URL" :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"))))
(:nvidia . (:base-url "https://integrate.api.nvidia.com/v1" :key-env "NVIDIA_API_KEY" :default-model "meta/llama-3.1-405b-instruct"))
(:ollama . (:base-url nil :key-env nil :url-env "OLLAMA_HOST" :default-model "llama3"))))
(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."
"Checks if a provider is configured. Checks API key or URL env vars."
(let* ((config (provider-config provider))
(key-env (getf config :key-env))
(url-env (getf config :url-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))))
(cond (key-env (let ((key (uiop:getenv key-env))) (and key (> (length key) 0))))
(url-env (let ((url (uiop:getenv url-env))) (and url (> (length url) 0))))
(base-url t))))
(defun provider-openai-request (prompt system-prompt &key model (provider :ollama))
(defun provider-openai-request (prompt system-prompt &key model (provider :openrouter))
"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))
(url-env (getf config :url-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"))
(url (if url-env
(let ((host (uiop:getenv url-env)))
(if host
(format nil "http://~a/v1/chat/completions" host)
(format nil "~a/chat/completions" base-url)))
(format nil "~a/chat/completions" base-url)))
(headers `(("Content-Type" . "application/json")
,@(when api-key `(("Authorization" . ,(format nil "Bearer ~a" api-key))))
@@ -71,11 +77,13 @@
(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*)))))
(setf *provider-cascade* (mapcar #'car (remove-if (lambda (e)
(member (car e) '(:local :ollama)))
*provider-configs*))))))
(provider-register-all)
(provider-cascade-initialize)
(defskill :passepartout-gateway-provider
(defskill :passepartout-system-model-provider
:priority 50
:trigger (lambda (ctx) (declare (ignore ctx)) nil))

14
lisp/system-model-router.lisp
View File

@@ -1,7 +1,7 @@
(in-package :passepartout)
(defvar *model-cascade-code* nil
"Cascade for :code tasks: ((:ollama . \"model\") ...)")
"Cascade for :code tasks: ((:provider . \"model\") ...)")
(defvar *model-cascade-plan* nil
"Cascade for :plan tasks.")
@@ -12,8 +12,8 @@
(defvar *model-cascade-background* nil
"Cascade for background tasks (heartbeat, delegation).")
(defvar *local-backends* '(:ollama :llama-cpp)
"Backend keywords considered local (privacy-safe).")
(defvar *local-backends* nil
"Backend keywords considered local (privacy-safe). Set via LOCAL_BACKENDS env var.")
(defun model-classify-complexity (text)
"Classify TEXT into :code, :plan, or :chat."
@@ -53,7 +53,7 @@ Returns model name or :skip."
;; Quadrant: background tasks use background cascade
(if (member sensor '(:heartbeat :delegation :tool-output :loop-error))
(let ((entry (car (or *model-cascade-background*
'((:ollama . "phi-2"))))))
'((:openrouter . "meta-llama/llama-3.2-3b-instruct:free"))))))
(cdr entry))
;; Foreground: classify complexity, use slot cascade
(let* ((slot (model-classify-complexity text))
@@ -62,8 +62,8 @@ Returns model name or :skip."
(:plan *model-cascade-plan*)
(t *model-cascade-chat*)))
(entry (model-cascade-find
(or cascade '((:ollama . "qwen2.5:14b"))) backend)))
(if entry (cdr entry) :skip)))))
(or cascade '((:openrouter . "meta-llama/llama-3.3-70b-instruct:free"))) backend)))
(if entry (cdr entry) nil)))))
(defun model-router-init ()
"Read env vars and wire model-select into *model-selector*."
@@ -79,7 +79,7 @@ Returns model name or :skip."
(if env
(mapcar (lambda (s) (intern (string-upcase (string-trim " " s)) :keyword))
(uiop:split-string env :separator '(#\,)))
'(:ollama :llama-cpp)))))
nil))))
(setf *model-selector* #'model-select)
(log-message "MODEL-ROUTER: Initialized, selector=~a" *model-selector*))

16
lisp/system-model.lisp Normal file
View File

@@ -0,0 +1,16 @@
(in-package :passepartout)
(defun model-request (&key prompt system-prompt (provider :openrouter) 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-system-model
:priority 100
:trigger (lambda (ctx) (getf ctx :user-input))
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))