(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)

(defvar *model-selector* nil)

(defvar *consensus-enabled* nil)

(defun backend-register (name fn)
  (setf (gethash name *backend-registry*) fn))

(defun backend-cascade-call (prompt &key
                                (system-prompt "You are the Probabilistic engine.")
                                (cascade nil)
                                (context nil))
  (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 ""))
        (setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
        (setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
        (string-trim '(#\Space #\Newline #\Tab) cleaned))
      text))

(defun plist-keywords-normalize (plist)
  (when (listp plist)
    (loop for (k v) on plist by #'cddr
          collect (if (and (symbolp k) (not (keywordp k)))
                       (intern (string k) :keyword)
                       k)
          collect v)))

(defun think (context)
  (let* ((active-skill (find-triggered-skill context))
         (tool-belt (generate-tool-belt-prompt))
         (global-context (context-assemble-global-awareness))
         (system-logs (context-get-system-logs))
         (assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent"))
         (rejection-trace (proto-get (proto-get context :payload) :rejection-trace))
         (prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
         (raw-prompt (if prompt-generator
                         (funcall prompt-generator context)
                         (let ((p (proto-get (proto-get context :payload) :text)))
                           (if (and p (stringp p)) p "Maintain metabolic stasis."))))
         (reflection-feedback (if rejection-trace
                                  (format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
                                  ""))
         (skill-augments (let ((augments ""))
                           (maphash (lambda (name skill)
                                      (declare (ignore name))
                                      (let ((aug-fn (skill-system-prompt-augment skill)))
                                        (when aug-fn
                                          (let ((aug-text (ignore-errors (funcall aug-fn context))))
                                            (when (and aug-text (stringp aug-text) (> (length aug-text) 0))
                                              (setf augments (concatenate 'string augments aug-text (string #\Newline))))))))
                                    *skill-registry*)
                           (when (> (length augments) 0) augments)))
         (system-prompt (format nil "IDENTITY: ~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a~%~a" 
                                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 (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 (let ((*read-eval* nil)) (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,
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)
        (gates nil)
        (gate-trace nil))
    ;; Collect gates sorted by priority (highest first)
    (maphash (lambda (name skill)
               (declare (ignore name))
               (when (skill-deterministic-fn skill)
                 (push (cons (skill-priority skill) (cons (skill-name skill) (skill-deterministic-fn skill))) gates)))
             *skill-registry*)
    (setf gates (sort gates #'> :key #'car))
    (dolist (gate-entry gates)
      (let* ((gate-name (cadr gate-entry))
             (result (funcall (cddr gate-entry) current-action context)))
        (cond
          ((eq (getf result :level) :approval-required)
           (push (list :gate (or gate-name (car gate-entry)) :result :approval) gate-trace)
           (setf approval-needed t
                 approval-action (getf (getf result :payload) :action)))
          ((member (getf result :type) '(:LOG :EVENT))
           (push (list :gate (or gate-name (car gate-entry)) :result :blocked) gate-trace)
           (return-from cognitive-verify
             (list* :gate-trace (nreverse gate-trace) result)))
          ((and (listp result) result)
           (push (list :gate (or gate-name (car gate-entry)) :result :passed) gate-trace)
           (setf current-action result)))))
    (if approval-needed
        (list :type :EVENT :level :approval-required
              :gate-trace (nreverse gate-trace)
              :payload (list :sensor :approval-required
                             :action approval-action))
        (list* :gate-trace (nreverse gate-trace) current-action))))

(defun loop-gate-reason (signal)
  (let* ((type (proto-get signal :type))
         (payload (proto-get signal :payload))
         (sensor (proto-get payload :sensor)))
    (unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message)))
      (return-from loop-gate-reason signal))
    (let ((retries 3)
          (current-signal (copy-tree signal))
          (last-rejection nil))
      (loop
        (when (<= retries 0)
          (setf (getf signal :approved-action) last-rejection)
          (setf (getf signal :status) :reasoned)
          (return signal))
        (when last-rejection
          (setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
        (let ((candidate (think current-signal)))
           (if (and candidate (listp candidate))
               (let ((verified (cognitive-verify candidate current-signal)))
                 ;; Approval-required is not a rejection — pass to act for Flight Plan
                 (if (eq (getf verified :level) :approval-required)
                     (progn
                       (setf (getf signal :approved-action) verified)
                       (setf (getf signal :status) :requires-approval)
                       (return signal))
                     ;; Hard rejection: retry with feedback
                     (if (member (getf verified :type) '(:LOG :EVENT))
                         (progn (decf retries) (setf last-rejection verified))
                         (progn
                           (setf (getf signal :approved-action) verified)
                           (setf (getf signal :status) :reasoned)
                           (return signal)))))
              (progn
                (setf (getf signal :approved-action) nil)
                (setf (getf signal :status) :reasoned)
                (return signal))))))))

(defun reason-gate (signal)
  (loop-gate-reason signal))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :fiveam :silent t))

(defpackage :passepartout-pipeline-reason-tests
  (:use :cl :fiveam :passepartout)
  (:export #:pipeline-reason-suite))

(in-package :passepartout-pipeline-reason-tests)

(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline")
(in-suite pipeline-reason-suite)

(test test-decide-gate-safety
  "Contract 1: cognitive-verify blocks unsafe actions with :LOG rejection."
  (clrhash passepartout::*skill-registry*)
  (passepartout::defskill :mock-safety
    :priority 50
    :trigger (lambda (ctx) (declare (ignore ctx)) t)
    :deterministic (lambda (action ctx)
                    (declare (ignore ctx))
                    (if (search "rm -rf" (format nil "~s" action))
                        (list :type :LOG :payload (list :text "Rejected"))
                        action)))
  (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /")))
         (signal '(:type :EVENT :payload (:sensor :user-input)))
         (result (cognitive-verify candidate signal)))
    (is (eq :LOG (getf result :type)))))

(test test-cognitive-verify-pass-through
  "Contract 1: safe actions pass through cognitive-verify unchanged."
  (clrhash passepartout::*skill-registry*)
  (passepartout::defskill :mock-passthrough
    :priority 50
    :trigger (lambda (ctx) (declare (ignore ctx)) t)
    :deterministic (lambda (action ctx)
                    (declare (ignore ctx))
                    action))
  (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello")))
         (signal '(:type :EVENT :payload (:sensor :user-input)))
         (result (cognitive-verify candidate signal)))
    (is (eq :REQUEST (getf result :type)))
    (is (equal (getf candidate :payload) (getf result :payload)))
    (is (getf result :gate-trace))))

(test test-cognitive-verify-empty-registry
  "Contract 1: with no gates registered, action passes through unchanged."
  (clrhash passepartout::*skill-registry*)
  (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls")))
         (signal '(:type :EVENT :payload (:sensor :user-input)))
         (result (cognitive-verify candidate signal)))
    (is (eq :REQUEST (getf result :type)))
    (is (equal (getf candidate :payload) (getf result :payload)))))

(test test-cognitive-verify-approval-required
  "Contract 1: gate returning :approval-required produces an approval event."
  (clrhash passepartout::*skill-registry*)
  (passepartout::defskill :mock-approval
    :priority 50
    :trigger (lambda (ctx) (declare (ignore ctx)) t)
    :deterministic (lambda (action ctx)
                    (declare (ignore ctx))
                    (list :type :EVENT :level :approval-required
                          :payload (list :action action))))
  (let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "sudo reboot")))
         (signal '(:type :EVENT :payload (:sensor :user-input)))
         (result (cognitive-verify candidate signal)))
    (is (eq :approval-required (getf result :level)))
    (is (eq :EVENT (getf result :type)))))

(test test-loop-gate-reason-passthrough
  "Contract 2: non-user-input sensors pass through loop-gate-reason unchanged."
  (let* ((signal '(:type :EVENT :payload (:sensor :heartbeat) :meta (:source :system)))
         (result (loop-gate-reason signal)))
    (is (not (null result)))))

(test test-loop-gate-reason-sets-status
  "Contract 2: loop-gate-reason sets :status on :user-input signals."
  (clrhash passepartout::*skill-registry*)
  (let* ((passepartout::*provider-cascade* nil)
         (signal (list :type :EVENT :payload (list :sensor :user-input :text "test")))
         (result (loop-gate-reason signal)))
    (is (member (getf result :status) '(:reasoned :requires-approval)))))

(test test-backend-cascade-no-backends
  "Contract 4: empty cascade returns :LOG failure."
  (let* ((passepartout::*provider-cascade* nil)
         (passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
         (result (backend-cascade-call "test" :cascade '())))
    (is (eq :LOG (getf result :type)))
    (is (search "exhausted" (getf (getf result :payload) :text) :test #'char-equal))))

(test test-backend-cascade-with-mock
  "Contract 4: backend-cascade-call returns content from first successful backend."
  (let ((passepartout::*backend-registry* (make-hash-table :test 'equal)))
    (setf (gethash :mock-backend passepartout::*backend-registry*)
          (lambda (prompt sp &key model)
            (declare (ignore prompt sp model))
            (list :status :success :content "mock-response")))
    (let ((result (backend-cascade-call "hello" :cascade '(:mock-backend))))
      (is (string= "mock-response" result)))))

(test test-read-eval-rce-blocked
  "Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code."
  (let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
        (passepartout::*provider-cascade* '(:mock-evil)))
    (setf (gethash :mock-evil passepartout::*backend-registry*)
          (lambda (prompt sp &key model)
            (declare (ignore prompt sp model))
            (list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))")))
    (setf passepartout::*v031-rce-test* nil)
    (setf *read-eval* t)
    (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "test") :depth 0))
           (result (passepartout::think ctx)))
      (is (not (eq passepartout::*v031-rce-test* :PWNED)))
      (is (eq :REQUEST (getf result :TYPE)))
      (setf *read-eval* nil))))