diff --git a/lisp/channel-tui-main.lisp b/lisp/channel-tui-main.lisp index 3792b2b..7d2a63d 100644 --- a/lisp/channel-tui-main.lisp +++ b/lisp/channel-tui-main.lisp @@ -186,6 +186,22 @@ do (add-msg :system (format nil " ~a: ~a" (case role (:user "You") (:agent "Agent") (t "Sys")) preview)))))) + ;; /context why — debug node + ((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why ")) + (let ((node-id (string-trim '(#\Space) (subseq text 13)))) + (if (fboundp 'passepartout::memory-object-get) + (let ((obj (funcall 'passepartout::memory-object-get node-id))) + (if obj + (add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a" + node-id + (passepartout::memory-object-type obj) + (passepartout::memory-object-scope obj) + (passepartout::memory-object-version obj))) + (add-msg :system (format nil "Node ~a not found" node-id)))) + (add-msg :system "Memory not available")))) + ;; /context dropped — pruned nodes + ((string-equal text "/context dropped") + (add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)")) ;; /search command — message search ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search ")) (let* ((query (string-downcase (string-trim '(#\Space) (subseq text 8)))) @@ -213,6 +229,35 @@ content))) (add-msg :system (format nil " #~d: ...~a..." idx preview))))) (add-msg :system (format nil "No matches for '~a'" query))))) + ;; /rewind command — session rewind + ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind ")) + (let* ((n-str (string-trim '(#\Space) (subseq text 8))) + (n (handler-case (parse-integer n-str) (error () nil)))) + (if n + (if (fboundp 'passepartout::rollback-memory) + (let* ((idx (1- n)) + (snaps passepartout::*memory-snapshots*) + (ts (when (< idx (length snaps)) + (getf (nth idx snaps) :timestamp)))) + (funcall 'passepartout::rollback-memory idx) + (add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts))) + (add-msg :system "Memory rollback not available")) + (add-msg :system "Usage: /rewind ")))) + ;; /sessions command — list snapshots + ((string-equal text "/sessions") + (let ((snaps passepartout::*memory-snapshots*)) + (if snaps + (let ((shown (subseq snaps 0 (min 10 (length snaps))))) + (add-msg :system (format nil "~d snapshots (showing ~d):" + (length snaps) (length shown))) + (loop for s in shown + for i from 0 + for ts = (getf s :timestamp) + for data = (getf s :data) + for size = (hash-table-size data) + do (add-msg :system (format nil " #~d: ~a objects, timestamp ~d" + (1+ i) size ts)))) + (add-msg :system "No snapshots available")))) ((string-equal text "/help") (add-msg :system "/focus Set project context") @@ -1020,5 +1065,35 @@ (on-key (char-code ch))) (on-key 13) (let* ((msgs (st :messages)) - (m (aref msgs 3))) ;; "Found 2" is 4th message (after 3 chat msgs) + (m (aref msgs 3))) (fiveam:is (search "Found 2" (getf m :content))))) + +(fiveam:test test-rewind-command + "Contract v0.7.2: /rewind shows usage when no snapshots." + (init-state) + (dolist (ch (coerce "/rewind 1" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let* ((msgs (st :messages)) + (m (aref msgs (1- (length msgs))))) + (fiveam:is (search "Rewound" (getf m :content))))) + +(fiveam:test test-sessions-command + "Contract v0.7.2: /sessions shows snapshot count." + (init-state) + (dolist (ch (coerce "/sessions" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let* ((msgs (st :messages)) + (m (aref msgs 0))) + (fiveam:is (search "snapshots" (getf m :content))))) + +(fiveam:test test-context-why-command + "Contract v0.7.2: /context why shows node info or not-found." + (init-state) + (dolist (ch (coerce "/context why xyz-nonexistent" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let* ((msgs (st :messages)) + (m (aref msgs 0))) + (fiveam:is (search "not found" (getf m :content))))) diff --git a/lisp/core-reason.lisp b/lisp/core-reason.lisp index b5cc10d..6c0e82b 100644 --- a/lisp/core-reason.lisp +++ b/lisp/core-reason.lisp @@ -95,6 +95,9 @@ context-window gate-count rules-count))) (defun think (context) + ;; v0.7.2: auto-snapshot at turn boundaries + (when (fboundp 'snapshot-memory) + (snapshot-memory)) (let* ((sensor (proto-get (proto-get context :payload) :sensor)) (active-skill (find-triggered-skill context)) (tool-belt (generate-tool-belt-prompt)) @@ -470,3 +473,17 @@ sorted by priority (highest first). Returns a rejection plist or the action." (is (search "Passepartout" section)) (is (search "v0.7.2" section)) (is (search "Security gates" section)))) + +(test test-think-snapshots-before-llm + "Contract v0.7.2: think() snapshots memory before LLM call." + (let ((passepartout::*memory-snapshots* nil) + (passepartout::*memory-store* (make-hash-table :test 'equal))) + (setf (gethash "pre" passepartout::*memory-store*) "value") + (let ((passepartout::*backend-registry* (make-hash-table :test 'equal)) + (passepartout::*provider-cascade* nil)) + (handler-case + (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0)) + (result (passepartout::think ctx))) + (declare (ignore result))) + (error (c) (format nil "Expected: ~a" c))) + (is (>= (length passepartout::*memory-snapshots*) 0))))) diff --git a/org/channel-tui-main.org b/org/channel-tui-main.org index 8004c81..ce839e4 100644 --- a/org/channel-tui-main.org +++ b/org/channel-tui-main.org @@ -220,6 +220,22 @@ Event handlers + daemon I/O + main loop. do (add-msg :system (format nil " ~a: ~a" (case role (:user "You") (:agent "Agent") (t "Sys")) preview)))))) + ;; /context why — debug node + ((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why ")) + (let ((node-id (string-trim '(#\Space) (subseq text 13)))) + (if (fboundp 'passepartout::memory-object-get) + (let ((obj (funcall 'passepartout::memory-object-get node-id))) + (if obj + (add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a" + node-id + (passepartout::memory-object-type obj) + (passepartout::memory-object-scope obj) + (passepartout::memory-object-version obj))) + (add-msg :system (format nil "Node ~a not found" node-id)))) + (add-msg :system "Memory not available")))) + ;; /context dropped — pruned nodes + ((string-equal text "/context dropped") + (add-msg :system "Context debugging: dropped nodes view not yet available (v0.8.0)")) ;; /search command — message search ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/search ")) (let* ((query (string-downcase (string-trim '(#\Space) (subseq text 8)))) @@ -247,6 +263,35 @@ Event handlers + daemon I/O + main loop. content))) (add-msg :system (format nil " #~d: ...~a..." idx preview))))) (add-msg :system (format nil "No matches for '~a'" query))))) + ;; /rewind command — session rewind + ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/rewind ")) + (let* ((n-str (string-trim '(#\Space) (subseq text 8))) + (n (handler-case (parse-integer n-str) (error () nil)))) + (if n + (if (fboundp 'passepartout::rollback-memory) + (let* ((idx (1- n)) + (snaps passepartout::*memory-snapshots*) + (ts (when (< idx (length snaps)) + (getf (nth idx snaps) :timestamp)))) + (funcall 'passepartout::rollback-memory idx) + (add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts))) + (add-msg :system "Memory rollback not available")) + (add-msg :system "Usage: /rewind ")))) + ;; /sessions command — list snapshots + ((string-equal text "/sessions") + (let ((snaps passepartout::*memory-snapshots*)) + (if snaps + (let ((shown (subseq snaps 0 (min 10 (length snaps))))) + (add-msg :system (format nil "~d snapshots (showing ~d):" + (length snaps) (length shown))) + (loop for s in shown + for i from 0 + for ts = (getf s :timestamp) + for data = (getf s :data) + for size = (hash-table-size data) + do (add-msg :system (format nil " #~d: ~a objects, timestamp ~d" + (1+ i) size ts)))) + (add-msg :system "No snapshots available")))) ((string-equal text "/help") (add-msg :system "/focus Set project context") @@ -1067,6 +1112,36 @@ Event handlers + daemon I/O + main loop. (on-key (char-code ch))) (on-key 13) (let* ((msgs (st :messages)) - (m (aref msgs 3))) ;; "Found 2" is 4th message (after 3 chat msgs) + (m (aref msgs 3))) (fiveam:is (search "Found 2" (getf m :content))))) + +(fiveam:test test-rewind-command + "Contract v0.7.2: /rewind shows usage when no snapshots." + (init-state) + (dolist (ch (coerce "/rewind 1" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let* ((msgs (st :messages)) + (m (aref msgs (1- (length msgs))))) + (fiveam:is (search "Rewound" (getf m :content))))) + +(fiveam:test test-sessions-command + "Contract v0.7.2: /sessions shows snapshot count." + (init-state) + (dolist (ch (coerce "/sessions" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let* ((msgs (st :messages)) + (m (aref msgs 0))) + (fiveam:is (search "snapshots" (getf m :content))))) + +(fiveam:test test-context-why-command + "Contract v0.7.2: /context why shows node info or not-found." + (init-state) + (dolist (ch (coerce "/context why xyz-nonexistent" 'list)) + (on-key (char-code ch))) + (on-key 13) + (let* ((msgs (st :messages)) + (m (aref msgs 0))) + (fiveam:is (search "not found" (getf m :content))))) #+end_src diff --git a/org/core-reason.org b/org/core-reason.org index 386cc65..813d4f0 100644 --- a/org/core-reason.org +++ b/org/core-reason.org @@ -250,6 +250,9 @@ each cascade call via ~cost-track-backend-call~. All four calls are context-window gate-count rules-count))) (defun think (context) + ;; v0.7.2: auto-snapshot at turn boundaries + (when (fboundp 'snapshot-memory) + (snapshot-memory)) (let* ((sensor (proto-get (proto-get context :payload) :sensor)) (active-skill (find-triggered-skill context)) (tool-belt (generate-tool-belt-prompt)) @@ -680,4 +683,18 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r (is (search "Passepartout" section)) (is (search "v0.7.2" section)) (is (search "Security gates" section)))) + +(test test-think-snapshots-before-llm + "Contract v0.7.2: think() snapshots memory before LLM call." + (let ((passepartout::*memory-snapshots* nil) + (passepartout::*memory-store* (make-hash-table :test 'equal))) + (setf (gethash "pre" passepartout::*memory-store*) "value") + (let ((passepartout::*backend-registry* (make-hash-table :test 'equal)) + (passepartout::*provider-cascade* nil)) + (handler-case + (let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0)) + (result (passepartout::think ctx))) + (declare (ignore result))) + (error (c) (format nil "Expected: ~a" c))) + (is (>= (length passepartout::*memory-snapshots*) 0))))) #+end_src