Initial Lime window manager

src/conditions.lisp

@@ -0,0 +1,46 @@
+(in-package #:lime.core)
+
+(define-condition lime-error (error)
+  ())
+
+(define-condition unknown-entity (lime-error)
+  ((kind :initarg :kind :reader unknown-entity-kind)
+   (id :initarg :id :reader unknown-entity-id))
+  (:report (lambda (condition stream)
+             (format stream "Unknown ~A: ~S"
+                     (unknown-entity-kind condition)
+                     (unknown-entity-id condition)))))
+
+(define-condition invalid-activity-membership (lime-error)
+  ((client-id :initarg :client-id :reader invalid-activity-membership-client-id)
+   (activity-id :initarg :activity-id
+                :reader invalid-activity-membership-activity-id))
+  (:report (lambda (condition stream)
+             (format stream "Client ~S does not belong to activity ~S."
+                     (invalid-activity-membership-client-id condition)
+                     (invalid-activity-membership-activity-id condition)))))
+
+(define-condition activation-blocked (lime-error)
+  ((report :initarg :report :reader activation-blocked-report))
+  (:report (lambda (condition stream)
+             (declare (ignore condition))
+             (format stream "The requested view activation has unresolved conflicts."))))
+
+(define-condition stale-transition-plan (lime-error)
+  ()
+  (:report (lambda (condition stream)
+             (declare (ignore condition))
+             (format stream "The transition plan was built against an older world state."))))
+
+(define-condition degraded-presentation-update (lime-error)
+  ((presentation-id :initarg :presentation-id))
+  (:report (lambda (condition stream)
+             (format stream
+                     "Presentation ~S has unavailable windows and cannot safely update a view."
+                     (slot-value condition 'presentation-id)))))
+
+(define-condition invalid-transition (lime-error)
+  ((description :initarg :description :reader invalid-transition-description))
+  (:report (lambda (condition stream)
+             (format stream "Invalid Lime transition: ~A"
+                     (invalid-transition-description condition)))))

src/floating-operations.lisp

@@ -0,0 +1,102 @@
+(in-package #:lime.core)
+
+;;;; Head-local floating placement commands
+;;;
+;;; Floating remains ordinary Presentation placement state: it has no special
+;;; lease semantics and is saved into a View only through the same explicit
+;;; checkpoint commands as tiling.  This file only changes the placement kind
+;;; and its normalized Head-relative rectangle.
+
+(defun presentation-client-floating-p (presentation client-id)
+  "Return true when CLIENT-ID has a floating placement in PRESENTATION."
+  (let ((placement (%placement-for-client (presentation-placements presentation)
+                                          client-id)))
+    (and placement (eq (placement-kind placement) :float))))
+
+(defun %require-placement (presentation client-id)
+  (or (%placement-for-client (presentation-placements presentation) client-id)
+      (error 'invalid-transition
+             :description "The client has no placement in this presentation.")))
+
+(defun %require-floating-placement (presentation client-id)
+  (let ((placement (%require-placement presentation client-id)))
+    (unless (eq (placement-kind placement) :float)
+      (error 'invalid-transition
+             :description "The command requires a floating client in this presentation."))
+    placement))
+
+(defun %refresh-layout-after-placement-kind-change (presentation client-id)
+  "Keep PRESENTATION's tiled tree consistent after CLIENT-ID changes kind."
+  (setf (presentation-layout-root presentation)
+        (if (eq (presentation-layout-mode presentation) :master-stack)
+            (layout-root-for-mode :master-stack
+                                  (presentation-layout-options presentation)
+                                  (presentation-placements presentation))
+            (if (presentation-client-floating-p presentation client-id)
+                (%remove-client-from-layout (presentation-layout-root presentation)
+                                            client-id)
+                (%insert-tiled-client-into-layout presentation client-id))))
+  presentation)
+
+(defun toggle-client-floating (world presentation-id client-id &key data)
+  "Toggle CLIENT-ID between tiled and floating in an active Presentation.
+
+When becoming a float, DATA is a complete or partial normalized rectangle
+plist.  Omitting it uses `DEFAULT-FLOATING-PLACEMENT-DATA`.  When returning to
+tiling, the current layout policy supplies the client's new tiling slot.
+Neither transition changes leases or focus."
+  (let* ((presentation (%require-active-presentation world presentation-id))
+         (placement (%require-placement presentation client-id))
+         (weight (placement-tile-weight placement)))
+    (cond
+      ((eq (placement-kind placement) :tile)
+       (let ((float-data (%canonical-floating-placement-data data)))
+         (setf (placement-kind placement) :float
+               (placement-data placement) (%data-with-tile-weight float-data weight))))
+      ((eq (placement-kind placement) :float)
+       (when data
+         (error 'invalid-transition
+                :description "Floating geometry is only accepted when converting a tiled client."))
+       (setf (placement-kind placement) :tile
+             (placement-data placement) (%data-with-tile-weight nil weight)))
+      (t
+       (error 'invalid-transition :description "Unknown placement kind.")))
+    (%refresh-layout-after-placement-kind-change presentation client-id)
+    (setf (presentation-dirty-p presentation) t)
+    (%touch world)
+    presentation))
+
+(defun toggle-focused-client-floating (world presentation-id &key data)
+  "Toggle the focused client between tiled and floating in PRESENTATION-ID."
+  (let* ((presentation (%require-active-presentation world presentation-id))
+         (client-id (presentation-focus-client-id presentation)))
+    (unless client-id
+      (error 'invalid-transition
+             :description "The presentation has no focused client to float."))
+    (toggle-client-floating world presentation-id client-id :data data)))
+
+(defun set-client-floating-geometry
+    (world presentation-id client-id
+     &key (x nil x-supplied-p) (y nil y-supplied-p)
+       (width nil width-supplied-p) (height nil height-supplied-p))
+  "Update a floating client's normalized Head-relative rectangle.
+
+Only supplied coordinates replace the current rectangle.  The resulting
+rectangle must remain wholly inside the Head's normalized 0..1 space."
+  (unless (or x-supplied-p y-supplied-p width-supplied-p height-supplied-p)
+    (error 'invalid-transition
+           :description "Floating geometry needs at least one supplied field."))
+  (let* ((presentation (%require-active-presentation world presentation-id))
+         (placement (%require-floating-placement presentation client-id))
+         (current (placement-data placement))
+         (data (%canonical-floating-placement-data
+                (list :x (if x-supplied-p x (getf current :x))
+                      :y (if y-supplied-p y (getf current :y))
+                      :width (if width-supplied-p width (getf current :width))
+                      :height (if height-supplied-p height
+                                  (getf current :height))))))
+    (setf (placement-data placement)
+          (%data-with-tile-weight data (placement-tile-weight placement))
+          (presentation-dirty-p presentation) t)
+    (%touch world)
+    presentation))

src/layout-operations.lisp

@@ -0,0 +1,304 @@
+(in-package #:lime.core)
+
+;;;; Head-local layout commands
+;;;
+;;; These commands mutate only an active Presentation.  They deliberately do
+;;; not know about CLX, keys, mouse drags, or saved View updates: frontends
+;;; render the result, and a View changes only through an explicit checkpoint
+;;; command.
+
+(defun %require-active-presentation (world presentation-id)
+  (let ((presentation (find-presentation world presentation-id)))
+    (unless (presentation-active-p world presentation)
+      (error 'invalid-transition
+             :description "Only an active presentation can change its layout."))
+    presentation))
+
+(defun %canonical-master-stack-options (options)
+  (multiple-value-bind (master-count master-ratio orientation)
+      (%master-stack-options options)
+    (list :master-count master-count
+          :master-ratio master-ratio
+          :orientation orientation)))
+
+(defun %active-layout-root (presentation)
+  "Return the actual tiled tree used by PRESENTATION before a manual edit."
+  (let ((placements (presentation-placements presentation)))
+    (case (presentation-layout-mode presentation)
+      (:master-stack
+       (layout-root-for-mode :master-stack
+                             (presentation-layout-options presentation)
+                             placements))
+      (otherwise
+       (or (presentation-layout-root presentation)
+           (default-layout-root (%tiled-client-ids placements)))))))
+
+(defun set-presentation-layout-mode (world presentation-id layout-mode
+                                     &key layout-options)
+  "Apply one built-in LAYOUT-MODE to an active Presentation.
+
+`:MANUAL` preserves the current explicit tree. `:MASTER-STACK` owns a
+canonical tree generated from tile placement order and its option plist.
+`:MONOCLE` preserves the tree but renders only the focused tiled client."
+  (let ((presentation (%require-active-presentation world presentation-id)))
+    (%validate-layout-mode layout-mode layout-options)
+    (let ((options
+            (case layout-mode
+              (:master-stack (%canonical-master-stack-options layout-options))
+              (otherwise
+               (when layout-options
+                 (error 'invalid-transition
+                        :description "Only :MASTER-STACK accepts layout options."))
+               nil))))
+      (setf (presentation-layout-root presentation)
+            (case layout-mode
+              (:master-stack
+               (layout-root-for-mode :master-stack options
+                                     (presentation-placements presentation)))
+              (otherwise
+               (%active-layout-root presentation)))
+            (presentation-layout-mode presentation) layout-mode
+            (presentation-layout-options presentation) options
+            (presentation-dirty-p presentation) t)
+      (%touch world)
+      presentation)))
+
+(defun set-presentation-master-stack-layout
+    (world presentation-id &key (master-count 1) (master-ratio 3/5)
+                               (orientation :horizontal))
+  "Use master/stack on PRESENTATION-ID, with the existing tile order.
+
+The first MASTER-COUNT tiled clients form the master area. New tiled windows
+retain this policy rather than silently reverting to the manual fallback."
+  (set-presentation-layout-mode
+   world presentation-id :master-stack
+   :layout-options (list :master-count master-count
+                         :master-ratio master-ratio
+                         :orientation orientation)))
+
+(defun set-presentation-monocle-layout (world presentation-id)
+  "Use monocle on PRESENTATION-ID, showing its focused tiled client only."
+  (set-presentation-layout-mode world presentation-id :monocle))
+
+(defun set-presentation-manual-layout (world presentation-id)
+  "Return PRESENTATION-ID to its current explicit binary layout tree."
+  (set-presentation-layout-mode world presentation-id :manual))
+
+(defun %require-tiled-placement (presentation client-id)
+  (let ((placement (%placement-for-client (presentation-placements presentation)
+                                           client-id)))
+    (unless (and placement (eq (placement-kind placement) :tile))
+      (error 'invalid-transition
+             :description "The layout command requires a tiled client in this presentation."))
+    placement))
+
+(defun %layout-contains-client-p (layout-root client-id)
+  (member client-id (layout-node-client-ids layout-root) :test #'equal))
+
+(defun set-client-tile-weight (world presentation-id client-id weight)
+  "Set CLIENT-ID's relative size within its master/stack column.
+
+Only this active draft changes. The column's other tiles share the remaining
+space proportionally; the master/stack divide, focus, order and leases stay
+intact. A sole tile still fills its column, retaining the weight for later."
+  (%validate-tile-weight weight)
+  (let* ((presentation (%require-active-presentation world presentation-id))
+         (placement (%require-tiled-placement presentation client-id)))
+    (unless (eq (presentation-layout-mode presentation) :master-stack)
+      (error 'invalid-transition
+             :description "Tile weight adjustment requires the master-stack layout."))
+    (unless (= weight (placement-tile-weight placement))
+      (setf (placement-data placement)
+            (%data-with-tile-weight (placement-data placement) weight)
+            (presentation-layout-root presentation)
+            (layout-root-for-mode :master-stack
+                                  (presentation-layout-options presentation)
+                                  (presentation-placements presentation))
+            (presentation-dirty-p presentation) t)
+      (%touch world))
+    presentation))
+
+(defun %map-layout-leaves (layout-root function)
+  (typecase layout-root
+    (null nil)
+    (layout-leaf
+     (make-layout-leaf :client-id (funcall function
+                                            (layout-leaf-client-id layout-root))))
+    (layout-split
+     (make-layout-split :orientation (layout-split-orientation layout-root)
+                        :ratio (layout-split-ratio layout-root)
+                        :first (%map-layout-leaves (layout-split-first layout-root)
+                                                    function)
+                        :second (%map-layout-leaves (layout-split-second layout-root)
+                                                     function)))))
+
+(defun %edit-direct-parent-split (layout-root client-id transform)
+  "Edit CLIENT-ID's nearest containing split and return ROOT, EDITED-P."
+  (typecase layout-root
+    (layout-leaf (values layout-root nil))
+    (layout-split
+     (let ((first (layout-split-first layout-root))
+           (second (layout-split-second layout-root)))
+       (cond
+         ((or (and (typep first 'layout-leaf)
+                   (equal (layout-leaf-client-id first) client-id))
+              (and (typep second 'layout-leaf)
+                   (equal (layout-leaf-client-id second) client-id)))
+          (values (funcall transform layout-root) t))
+         ((%layout-contains-client-p first client-id)
+          (multiple-value-bind (new-first edited-p)
+              (%edit-direct-parent-split first client-id transform)
+            (values (make-layout-split :orientation (layout-split-orientation layout-root)
+                                       :ratio (layout-split-ratio layout-root)
+                                       :first new-first :second second)
+                    edited-p)))
+         ((%layout-contains-client-p second client-id)
+          (multiple-value-bind (new-second edited-p)
+              (%edit-direct-parent-split second client-id transform)
+            (values (make-layout-split :orientation (layout-split-orientation layout-root)
+                                       :ratio (layout-split-ratio layout-root)
+                                       :first first :second new-second)
+                    edited-p)))
+         (t (values layout-root nil)))))))
+
+(defun %commit-manual-layout (world presentation layout-root)
+  ;; SET-PRESENTATION-LAYOUT-ROOT validates exact placement coverage, marks the
+  ;; draft dirty, and makes switching away from a built-in policy explicit.
+  (set-presentation-layout-root world (presentation-id presentation) layout-root))
+
+(defun set-focused-layout-split-orientation (world presentation-id orientation)
+  "Set the nearest split around the focused tiled client to ORIENTATION."
+  (unless (member orientation '(:horizontal :vertical))
+    (error 'invalid-transition
+           :description "A split orientation must be :HORIZONTAL or :VERTICAL."))
+  (let* ((presentation (%require-active-presentation world presentation-id))
+         (client-id (presentation-focus-client-id presentation)))
+    (unless client-id
+      (error 'invalid-transition :description "The presentation has no focused client."))
+    (%require-tiled-placement presentation client-id)
+    (multiple-value-bind (layout-root edited-p)
+        (%edit-direct-parent-split
+         (%active-layout-root presentation) client-id
+         (lambda (split)
+           (make-layout-split :orientation orientation
+                              :ratio (layout-split-ratio split)
+                              :first (layout-split-first split)
+                              :second (layout-split-second split))))
+      (unless edited-p
+        (error 'invalid-transition
+               :description "A one-client layout has no split to orient."))
+      (%commit-manual-layout world presentation layout-root))))
+
+(defun adjust-focused-layout-split-ratio (world presentation-id delta)
+  "Add DELTA to the nearest split around the focused tiled client.
+
+The result is clamped to 1/20 through 19/20 to retain usable space for both
+children while still allowing an intentionally dominant master area."
+  (unless (and (realp delta) (not (zerop delta)))
+    (error 'invalid-transition
+           :description "A split ratio adjustment must be a non-zero real number."))
+  (let* ((presentation (%require-active-presentation world presentation-id))
+         (client-id (presentation-focus-client-id presentation)))
+    (unless client-id
+      (error 'invalid-transition :description "The presentation has no focused client."))
+    (%require-tiled-placement presentation client-id)
+    (multiple-value-bind (layout-root edited-p)
+        (%edit-direct-parent-split
+         (%active-layout-root presentation) client-id
+         (lambda (split)
+           (make-layout-split
+            :orientation (layout-split-orientation split)
+            :ratio (max 1/20 (min 19/20 (+ (layout-split-ratio split) delta)))
+            :first (layout-split-first split)
+            :second (layout-split-second split))))
+      (unless edited-p
+        (error 'invalid-transition
+               :description "A one-client layout has no split to resize."))
+      (%commit-manual-layout world presentation layout-root))))
+
+(defun swap-presentation-layout-clients (world presentation-id first-client-id
+                                          second-client-id)
+  "Swap two tiled clients' slots, retaining master/stack policy when active."
+  (let ((presentation (%require-active-presentation world presentation-id)))
+    (%require-tiled-placement presentation first-client-id)
+    (%require-tiled-placement presentation second-client-id)
+    (when (eq (presentation-layout-mode presentation) :master-stack)
+      ;; Move the placements themselves: each window keeps its own weight.
+      ;; Editing only the generated tree would leave master/stack for manual
+      ;; mode and prevent subsequent column-share adjustments.
+      (let ((first (%placement-for-client (presentation-placements presentation)
+                                          first-client-id))
+            (second (%placement-for-client (presentation-placements presentation)
+                                           second-client-id)))
+        (setf (presentation-placements presentation)
+              (mapcar (lambda (placement)
+                        (cond ((eq placement first) second)
+                              ((eq placement second) first)
+                              (t placement)))
+                      (presentation-placements presentation))
+              (presentation-layout-root presentation)
+              (layout-root-for-mode :master-stack
+                                    (presentation-layout-options presentation)
+                                    (presentation-placements presentation))
+              (presentation-dirty-p presentation) t)
+        (%touch world)
+        (return-from swap-presentation-layout-clients presentation)))
+    (let ((layout-root (%active-layout-root presentation)))
+      (%commit-manual-layout
+       world presentation
+       (%map-layout-leaves
+        layout-root
+        (lambda (client-id)
+          (cond ((equal client-id first-client-id) second-client-id)
+                ((equal client-id second-client-id) first-client-id)
+                (t client-id))))))))
+
+(defun swap-focused-layout-client (world presentation-id &key (direction :next))
+  "Swap the focused client with the next or previous visible tiled client."
+  (unless (member direction '(:next :previous))
+    (error 'invalid-transition
+           :description "Layout swap direction must be :NEXT or :PREVIOUS."))
+  (let* ((presentation (%require-active-presentation world presentation-id))
+         (focus-client-id (presentation-focus-client-id presentation)))
+    (unless focus-client-id
+      (error 'invalid-transition :description "The presentation has no focused client."))
+    (%require-tiled-placement presentation focus-client-id)
+    (let* ((layout-client-ids (layout-node-client-ids
+                               (%active-layout-root presentation)))
+           (visible-client-ids
+             (remove-if-not
+              (lambda (client-id)
+                (let ((lease (lease-for-client world client-id)))
+                  (and lease
+                       (equal (lease-presentation-id lease)
+                              (presentation-id presentation)))))
+              layout-client-ids)))
+      (when (< (length visible-client-ids) 2)
+        (error 'invalid-transition
+               :description "Layout swap requires two visible tiled clients."))
+      (let* ((ordered (if (eq direction :previous)
+                          (reverse visible-client-ids)
+                          visible-client-ids))
+             (suffix (member focus-client-id ordered :test #'equal))
+             (other-client-id (or (second suffix) (first ordered))))
+        (swap-presentation-layout-clients world presentation-id focus-client-id
+                                          other-client-id)))))
+
+(defun promote-client-to-master (world presentation-id client-id)
+  "Make CLIENT-ID the first master/stack client in PRESENTATION-ID.
+
+Promoting is explicit: it switches the live draft to master/stack, preserves
+existing master/stack options when present, and never alters a saved View."
+  (let ((presentation (%require-active-presentation world presentation-id)))
+    (%require-tiled-placement presentation client-id)
+    (let* ((placement (%placement-for-client (presentation-placements presentation)
+                                             client-id))
+           (options (if (eq (presentation-layout-mode presentation) :master-stack)
+                        (presentation-layout-options presentation)
+                        nil)))
+      (setf (presentation-placements presentation)
+            (cons placement
+                  (remove client-id (presentation-placements presentation)
+                          :key #'placement-client-id :test #'equal)))
+      (set-presentation-layout-mode world presentation-id :master-stack
+                                    :layout-options options))))

src/layout.lisp

@@ -0,0 +1,209 @@
+(in-package #:lime.core)
+
+;;;; Head-local layout resolution
+
+(defstruct geometry
+  "An integer rectangle in a Head's usable coordinate space."
+  x
+  y
+  width
+  height)
+
+(defun default-layout-root (client-ids)
+  "Build Lime's deliberately boring fallback tree.
+
+It is used when a View has tiled placements but no explicit tree yet, and when
+a newly opened tiled client is added to a draft.  Higher-level layout policy
+can replace this without changing the lease model."
+  (reduce (lambda (tree client-id)
+            (make-layout-split :orientation :horizontal
+                               :ratio 1/2
+                               :first tree
+                               :second (make-layout-leaf :client-id client-id)))
+          (rest client-ids)
+          :initial-value (and client-ids
+                              (make-layout-leaf :client-id (first client-ids)))))
+
+(defun %linear-layout-root (client-ids orientation weights)
+  "Build proportional slices for CLIENT-IDS in their existing order."
+  (labels ((build (remaining remaining-weights total)
+             (cond
+               ((null remaining) nil)
+               ((null (rest remaining))
+                (make-layout-leaf :client-id (first remaining)))
+               (t
+                (make-layout-split
+                 :orientation orientation
+                 :ratio (/ (first remaining-weights) total)
+                 :first (make-layout-leaf :client-id (first remaining))
+                 :second (build (rest remaining) (rest remaining-weights)
+                                (- total (first remaining-weights))))))))
+    (build client-ids weights (reduce #'+ weights :initial-value 0))))
+
+(defun %master-stack-options (options)
+  "Return validated master/stack parameters from a layout option plist."
+  (let ((master-count (getf options :master-count 1))
+        (master-ratio (getf options :master-ratio 3/5))
+        (orientation (getf options :orientation :horizontal)))
+    (unless (and (integerp master-count) (plusp master-count))
+      (error 'invalid-transition
+             :description "Master/stack :MASTER-COUNT must be a positive integer."))
+    (unless (and (realp master-ratio) (< 0 master-ratio 1))
+      (error 'invalid-transition
+             :description "Master/stack :MASTER-RATIO must be strictly between zero and one."))
+    (unless (member orientation '(:horizontal :vertical))
+      (error 'invalid-transition
+             :description "Master/stack :ORIENTATION must be :HORIZONTAL or :VERTICAL."))
+    (values master-count master-ratio orientation)))
+
+(defun master-stack-layout-root (client-ids
+                                 &key (master-count 1)
+                                   (master-ratio 3/5)
+                                   (orientation :horizontal) weights)
+  "Build a conventional master/stack tree for CLIENT-IDS.
+
+The first MASTER-COUNT clients form the master area; the remaining clients
+share the stack. WEIGHTS, when supplied, is a list of positive relative sizes
+in CLIENT-IDS order; otherwise all sizes are equal. Each column normalizes its
+weights independently. ORIENTATION controls the master/stack divide, while
+the two areas subdivide across the other axis. No geometry is resolved here."
+  (%master-stack-options (list :master-count master-count
+                               :master-ratio master-ratio
+                               :orientation orientation))
+  (unless (or (null weights)
+              (and (listp weights) (= (length weights) (length client-ids))))
+    (error 'invalid-transition
+           :description "Master/stack needs one weight per tiled client."))
+  (setf weights (or weights (make-list (length client-ids) :initial-element 1)))
+  (mapc #'%validate-tile-weight weights)
+  (let* ((effective-master-count (min master-count (length client-ids)))
+         (masters (subseq client-ids 0 effective-master-count))
+         (stack (nthcdr effective-master-count client-ids))
+         (cross-orientation (ecase orientation
+                              (:horizontal :vertical)
+                              (:vertical :horizontal)))
+         (master-root (%linear-layout-root masters cross-orientation
+                                            (subseq weights 0 effective-master-count)))
+         (stack-root (%linear-layout-root stack cross-orientation
+                                           (nthcdr effective-master-count weights))))
+    (cond
+      ((null master-root) nil)
+      ((null stack-root) master-root)
+      (t
+       (make-layout-split :orientation orientation
+                          :ratio master-ratio
+                          :first master-root
+                          :second stack-root)))))
+
+(defun layout-root-for-mode (layout-mode layout-options placements)
+  "Build the canonical tree required by LAYOUT-MODE for PLACEMENTS.
+
+Manual and monocle presentations retain their explicit tree; callers use this
+function when a built-in mode needs to refresh its stored checkpoint tree."
+  (let ((client-ids (%tiled-client-ids placements)))
+    (ecase layout-mode
+      (:master-stack
+       (multiple-value-bind (master-count master-ratio orientation)
+           (%master-stack-options layout-options)
+         (master-stack-layout-root client-ids
+                                   :master-count master-count
+                                   :master-ratio master-ratio
+                                   :orientation orientation
+                                   :weights (loop for placement in placements
+                                                  when (eq (placement-kind placement) :tile)
+                                                    collect (placement-tile-weight placement)))))
+      ((:manual :monocle)
+       (default-layout-root client-ids)))))
+
+(defun %bounded-split-size (extent ratio)
+  "Return a positive size for the first child of a split.
+
+For a pathological one-pixel Head, both children intentionally receive a
+one-pixel rectangle.  The X11 adapter normally works with much larger work
+areas; preserving positive dimensions here keeps the function total."
+  (if (> extent 1)
+      (max 1 (min (1- extent) (round (* extent ratio))))
+      1))
+
+(defun %resolve-layout-node (layout-root x y width height)
+  (typecase layout-root
+    (null '())
+    (layout-leaf
+     (list (cons (layout-leaf-client-id layout-root)
+                 (make-geometry :x x :y y :width width :height height))))
+    (layout-split
+     (ecase (layout-split-orientation layout-root)
+       (:horizontal
+        (let* ((first-width (%bounded-split-size width
+                                                  (layout-split-ratio layout-root)))
+               (second-width (max 1 (- width first-width))))
+          (append (%resolve-layout-node (layout-split-first layout-root)
+                                        x y first-width height)
+                  (%resolve-layout-node (layout-split-second layout-root)
+                                        (+ x first-width) y second-width height))))
+       (:vertical
+        (let* ((first-height (%bounded-split-size height
+                                                   (layout-split-ratio layout-root)))
+               (second-height (max 1 (- height first-height))))
+          (append (%resolve-layout-node (layout-split-first layout-root)
+                                        x y width first-height)
+                  (%resolve-layout-node (layout-split-second layout-root)
+                                        x (+ y first-height) width second-height))))))))
+
+(defun %normalized-value (data key default)
+  (let ((value (and (listp data) (getf data key default))))
+    (if (realp value)
+        (max 0 (min 1 value))
+        default)))
+
+(defun %resolve-float-placement (placement x y width height)
+  (let* ((data (placement-data placement))
+         (left (%normalized-value data :x 0))
+         (top (%normalized-value data :y 0))
+         (relative-width (%normalized-value data :width 1))
+         (relative-height (%normalized-value data :height 1))
+         (resolved-width (max 1 (round (* width relative-width))))
+         (resolved-height (max 1 (round (* height relative-height)))))
+    (cons (placement-client-id placement)
+          (make-geometry :x (+ x (round (* width left)))
+                         :y (+ y (round (* height top)))
+                         :width resolved-width
+                         :height resolved-height))))
+
+(defun resolve-presentation-layout (presentation width height &key (x 0) (y 0))
+  "Resolve PRESENTATION's Head-local layout into an alist of client geometry.
+
+The function is deliberately pure: it does not know which clients currently
+hold leases, nor does it perform X11 effects.  The backend filters this result
+through leases before mapping clients."
+  (let* ((placements (presentation-placements presentation))
+         (tiled-client-ids (%tiled-client-ids placements))
+         (layout-root
+           (case (presentation-layout-mode presentation)
+             (:master-stack
+              (layout-root-for-mode :master-stack
+                                    (presentation-layout-options presentation)
+                                    placements))
+             (otherwise
+              (or (presentation-layout-root presentation)
+                  (default-layout-root tiled-client-ids)))))
+         (tiling
+           (if (eq (presentation-layout-mode presentation) :monocle)
+               (let ((client-id (if (member (presentation-focus-client-id presentation)
+                                           tiled-client-ids :test #'equal)
+                                    (presentation-focus-client-id presentation)
+                                    (first tiled-client-ids))))
+                 (if client-id
+                     (list (cons client-id
+                                 (make-geometry :x x :y y
+                                                :width (max 1 width)
+                                                :height (max 1 height))))
+                     '()))
+               (%resolve-layout-node layout-root x y (max 1 width) (max 1 height))))
+         (floating (loop for placement in placements
+                         when (eq (placement-kind placement) :float)
+                           collect (%resolve-float-placement placement
+                                                             x y
+                                                             (max 1 width)
+                                                             (max 1 height)))))
+    (append tiling floating)))

src/membership.lisp

@@ -0,0 +1,276 @@
+(in-package #:lime.core)
+
+;;;; Explicit membership transitions. Plan copies first, then commit without
+;;;; calling user policy or rendering midway through a lease/ownership change.
+
+(defun activity-deletion-summary (world activity-id)
+  "Describe deletion without changing anything. Owned clients and mounts block it."
+  (let* ((activity (find-activity world activity-id))
+         (clients (copy-list (activity-client-ids activity)))
+         (views (copy-list (activity-view-ids activity)))
+         (heads (loop for head being the hash-values of (world-heads world)
+                      for p = (current-presentation world (head-id head))
+                      when (and p (equal activity-id (presentation-activity-id p)))
+                        collect (head-id head)))
+         (drafts (loop for p being the hash-values of (world-presentations world)
+                       when (equal activity-id (presentation-activity-id p))
+                         collect (presentation-id p)))
+         (viewsets nil) (empty-viewsets nil) (entry-count 0))
+    (dolist (viewset (list-viewsets world))
+      (let ((count (count-if (lambda (entry) (member (viewset-entry-view-id entry) views :test #'equal))
+                             (viewset-entries viewset))))
+        (when (plusp count)
+          (incf entry-count count)
+          (push (viewset-id viewset) viewsets)
+          (when (= count (length (viewset-entries viewset)))
+            (push (viewset-id viewset) empty-viewsets)))))
+    (list :activity-id activity-id :name (activity-name activity)
+          :revision (world-revision world) :ready-p (not (or clients heads))
+          :client-ids clients :head-ids heads :view-ids views :presentation-ids drafts
+          :viewset-ids (nreverse viewsets) :empty-viewset-ids (nreverse empty-viewsets)
+          :viewset-entry-count entry-count)))
+
+(defun delete-activity (world activity-id &key expected-revision)
+  "Delete an unmounted Activity with no home clients, never closing any client.
+
+Removes its saved Views and cached/suspended drafts. References in Viewsets
+are pruned, deleting a Viewset only when it would become empty. Shared guests
+keep their homes and leases elsewhere. EXPECTED-REVISION protects an earlier
+confirmation from state changes. No mutation occurs until all checks pass."
+  (when (and expected-revision (/= expected-revision (world-revision world)))
+    (error 'stale-transition-plan))
+  (validate-world world)
+  (let* ((summary (activity-deletion-summary world activity-id))
+         (views (getf summary :view-ids))
+         (updates nil))
+    (when (getf summary :client-ids)
+      (error 'invalid-transition
+             :description "Move or close all windows owned by this Activity first, including hidden/shared windows."))
+    (when (getf summary :head-ids)
+      (error 'invalid-transition
+             :description "Switch every Head away from this Activity before deleting it."))
+    (dolist (id (getf summary :viewset-ids))
+      (let ((viewset (find-viewset world id)))
+        (push (cons viewset
+                    (remove-if (lambda (entry) (member (viewset-entry-view-id entry) views :test #'equal))
+                               (viewset-entries viewset)))
+              updates)))
+    ;; All validation and list construction precede the commit.
+    (dolist (update updates)
+      (if (cdr update)
+          (setf (viewset-entries (car update)) (cdr update))
+          (remhash (viewset-id (car update)) (world-viewsets world))))
+    (dolist (id views) (remhash id (world-views world)))
+    (dolist (id (getf summary :presentation-ids)) (remhash id (world-presentations world)))
+    (remhash activity-id (world-activities world))
+    (%touch world)
+    summary))
+
+(defun %client-removal-updates (world client-id predicate focus-direction)
+  (let (updates)
+    (dolist (table (list (world-views world) (world-presentations world)))
+      (maphash
+       (lambda (id container)
+         (declare (ignore id))
+         (when (and (%placement-for-client (slot-value container 'placements) client-id)
+                    (funcall predicate container))
+           (let* ((presentation-p (typep container 'presentation))
+                  (copy (if presentation-p (copy-presentation container) (copy-view container)))
+                  (old-ids (%placement-client-ids (slot-value container 'placements)))
+                  (old-focus (slot-value container 'focus-client-id))
+                  (direction (%focus-direction-for-container focus-direction container)))
+             (%remove-client-from-container copy client-id)
+             (when presentation-p
+               (setf (presentation-unavailable-client-ids copy)
+                     (%remove-id client-id (presentation-unavailable-client-ids copy))
+                     (presentation-dirty-p copy) t))
+             (when (equal old-focus client-id)
+               (setf (slot-value copy 'focus-client-id)
+                     (%focus-replacement-after-removal
+                      old-ids client-id
+                      (if (and presentation-p (presentation-active-p world container))
+                          (remove client-id (presentation-leased-client-ids world container) :test #'equal)
+                          (%placement-client-ids (slot-value copy 'placements)))
+                      direction)))
+             (push (cons container copy) updates))))
+       table))
+    updates))
+
+(defun %commit-container-updates (updates)
+  ;; Preserve object identity: the adapter and callers may retain a draft.
+  (dolist (update updates)
+    (let ((original (car update)) (copy (cdr update)))
+      (dolist (slot '(placements layout-root focus-client-id))
+        (setf (slot-value original slot) (slot-value copy slot)))
+      (when (typep original 'presentation)
+        (setf (presentation-unavailable-client-ids original) (presentation-unavailable-client-ids copy)
+              (presentation-dirty-p original) (presentation-dirty-p copy))))))
+
+(defun set-client-shared (world client-id shared-p &key (focus-direction :previous))
+  "Make a client eligible everywhere, or private to its existing home.
+
+Sharing never changes placements or leases. Revoking sharing prunes foreign
+Views/drafts and releases a foreign lease, without summoning the client home."
+  (unless (member shared-p '(nil t))
+    (error 'invalid-transition :description "SHARED-P must be T or NIL."))
+  (let ((client (find-client world client-id)))
+    (unless (eql (client-shared-p client) shared-p)
+      (let* ((home (client-activity-id client))
+             (updates (unless shared-p
+                        (%client-removal-updates
+                         world client-id (lambda (c) (not (equal home (slot-value c 'activity-id))))
+                         focus-direction)))
+             (lease (lease-for-client world client-id))
+             (release-p (and (not shared-p) lease
+                             (not (equal home (presentation-activity-id
+                                               (find-presentation world (lease-presentation-id lease))))))))
+        (%commit-container-updates updates)
+        (when release-p (remhash client-id (world-leases world)))
+        (setf (client-shared-p client) shared-p)
+        (%touch world)))
+    client))
+
+(defun make-client-private-in-presentation
+    (world client-id presentation-id &key (focus-direction :previous) expected-revision)
+  "Make a leased window private to the Activity where it is currently used.
+
+Preserve the current lease and arrangement exactly. Prepare foreign View/draft
+cleanup before atomically changing home membership and sharing. Unlike a move,
+this never parks, reinserts, focuses, or relocates the client."
+  (when (and expected-revision (/= expected-revision (world-revision world)))
+    (error 'stale-transition-plan))
+  (let* ((client (find-client world client-id))
+         (presentation (find-presentation world presentation-id))
+         (lease (lease-for-client world client-id))
+         (old-home (find-activity world (client-activity-id client)))
+         (home (find-activity world (presentation-activity-id presentation))))
+    (unless (and (presentation-active-p world presentation)
+                 lease (equal presentation-id (lease-presentation-id lease))
+                 (member client-id (presentation-leased-client-ids world presentation) :test #'equal))
+      (error 'invalid-transition :description "Make private requires the window's current active arrangement."))
+    (%ensure-client-in-activity world client-id (activity-id home))
+    (when (client-shared-p client)
+      (let ((updates (%client-removal-updates
+                      world client-id
+                      (lambda (container) (not (equal (activity-id home) (slot-value container 'activity-id))))
+                      focus-direction)))
+        ;; All validation and user policy ran above, on prepared copies.
+        (%commit-container-updates updates)
+        (unless (eq old-home home)
+          (setf (activity-client-ids old-home) (%remove-id client-id (activity-client-ids old-home))
+                (activity-client-ids home) (%add-unique-id client-id (activity-client-ids home))
+                (client-activity-id client) (activity-id home)))
+        (setf (client-shared-p client) nil)
+        (%touch world)))
+    client))
+
+(defun %move-client-membership (world client-id activity-id
+                                &key target-head-id active-target-id inactive-target-id (default-layout :master-stack)
+                                  (tiled-insertion-position :back) (focus-direction :previous))
+  "Plan a membership move completely before committing containers and lease.
+
+The public parked-move and active-destination commands select distinct paths;
+only the latter explicitly authorizes a live destination lease."
+  (when (> (count-if #'identity (list target-head-id active-target-id inactive-target-id)) 1)
+    (error 'invalid-transition :description "Choose one move destination."))
+  (let* ((client (find-client world client-id))
+         (old-home (find-activity world (client-activity-id client)))
+         (destination (find-activity world activity-id))
+         (lease (lease-for-client world client-id))
+         (holder (and lease (find-presentation world (lease-presentation-id lease)))))
+    (when target-head-id (find-head world target-head-id))
+    (%validate-layout-mode default-layout nil)
+    (unless (%valid-tiled-insertion-position-p tiled-insertion-position)
+      (error 'invalid-transition :description "Tiled insertion position must be :FRONT or :BACK."))
+    (let* ((target (if (or active-target-id inactive-target-id)
+                       (find-presentation world (or active-target-id inactive-target-id))
+                       (and target-head-id (activity-draft-for-head world activity-id target-head-id))))
+           (new-p (and target-head-id (null target)))
+           (prepared (when (or target-head-id active-target-id inactive-target-id)
+                       (if target (copy-presentation target)
+                           (make-presentation :id (format nil "presentation-~D" (1+ (world-next-presentation-number world)))
+                                              :head-id target-head-id :activity-id activity-id
+                                              :layout-mode default-layout)))))
+      (when (and target (not (equal activity-id (presentation-activity-id target))))
+        (error 'invalid-transition :description "The move destination belongs to another Activity."))
+      (if active-target-id
+          (unless (and (presentation-active-p world target)
+                       (equal activity-id (presentation-activity-id target)))
+            (error 'invalid-transition :description "The explicit move destination must be active in its Activity."))
+          (when (and target (presentation-active-p world target))
+            (error 'invalid-transition :description "Move targets an inactive Activity draft; do not silently alter another active desk.")))
+      (when prepared
+        (unless (%placement-for-client (presentation-placements prepared) client-id)
+          (let ((placement (or (and holder (%placement-for-client (presentation-placements holder) client-id))
+                               (make-placement :client-id client-id))))
+            (setf placement (first (%copy-placements (list placement))))
+            (setf (presentation-placements prepared)
+                  (if (and (eq (placement-kind placement) :tile) (eq tiled-insertion-position :front))
+                      (cons placement (presentation-placements prepared))
+                      (append (presentation-placements prepared) (list placement))))
+            (when (eq (placement-kind placement) :tile)
+              (setf (presentation-layout-root prepared)
+                    (%insert-tiled-client-into-layout prepared client-id :position tiled-insertion-position)))))
+        (when (eq (presentation-layout-mode prepared) :master-stack)
+          (setf (presentation-layout-root prepared)
+                (layout-root-for-mode :master-stack (presentation-layout-options prepared)
+                                      (presentation-placements prepared))))
+        (setf (presentation-focus-client-id prepared) client-id
+              (presentation-dirty-p prepared) t
+              (presentation-unavailable-client-ids prepared)
+              (%remove-id client-id (presentation-unavailable-client-ids prepared))))
+      (let ((updates (%client-removal-updates
+                      world client-id
+                      (if (client-shared-p client)
+                          (lambda (c) (and (typep c 'presentation) (not (eq c target))))
+                          (lambda (c) (or (eq c holder)
+                                          (not (equal activity-id (slot-value c 'activity-id))))))
+                      focus-direction)))
+        ;; No validation/user callbacks beyond this point.
+        (%commit-container-updates updates)
+        (remhash client-id (world-leases world))
+        (unless (eq old-home destination)
+          (setf (activity-client-ids old-home) (%remove-id client-id (activity-client-ids old-home))
+                (activity-client-ids destination) (%add-unique-id client-id (activity-client-ids destination))
+                (client-activity-id client) activity-id))
+        (when prepared
+          (if new-p
+              (progn
+                (incf (world-next-presentation-number world))
+                (setf (gethash (presentation-id prepared) (world-presentations world)) prepared))
+              (%commit-container-updates (list (cons target prepared)))))
+        (when active-target-id
+          (setf (gethash client-id (world-leases world))
+                (make-lease :client-id client-id :presentation-id active-target-id)))
+        (%touch world)))
+    client))
+
+(defun move-client-to-activity (world client-id activity-id
+                                &key target-head-id target-presentation-id (default-layout :master-stack)
+                                  (tiled-insertion-position :back) (focus-direction :previous))
+  "Rehome CLIENT-ID and park it, without switching or taking another Head.
+
+With TARGET-HEAD-ID, queue it in that Activity's inactive arrangement for the
+Head. TARGET-PRESENTATION-ID instead queues it in that inactive arrangement,
+including one suspended after unplugging a monitor. Without either, park it.
+Private clients leave foreign saved
+Views and drafts; shared clients retain valid saved requests and sharing."
+  (%move-client-membership world client-id activity-id
+                           :target-head-id target-head-id :inactive-target-id target-presentation-id
+                           :default-layout default-layout
+                           :tiled-insertion-position tiled-insertion-position
+                           :focus-direction focus-direction))
+
+(defun move-client-to-presentation (world client-id presentation-id
+                                    &key (tiled-insertion-position :back) (focus-direction :previous))
+  "Explicitly rehome and lease CLIENT-ID to an already active arrangement.
+
+Neither Head switches Activities. Private clients leave old saved Views and
+live arrangements; the destination receives an unsaved placement preserving
+tile/float kind and geometry. Plan all policy before mutating membership,
+placements, or leases, so a rejected move cannot leave a half-moved client."
+  (let ((target (find-presentation world presentation-id)))
+    (%move-client-membership world client-id (presentation-activity-id target)
+                             :active-target-id presentation-id
+                             :tiled-insertion-position tiled-insertion-position
+                             :focus-direction focus-direction)))

src/model.lisp

@@ -0,0 +1,698 @@
+(in-package #:lime.core)
+
+;;;; Core vocabulary
+;;;
+;;; Activity     durable task container and client pool
+;;; View         immutable-ish, named one-Head checkpoint
+;;; Head         one independently addressable display rectangle
+;;; Presentation mutable, Head-local realization of an activity/view
+;;; Lease        exclusive runtime right to map one real client in a presentation
+
+(defun %make-id-table ()
+  (make-hash-table :test #'equal))
+
+(defstruct (world (:constructor %make-world))
+  (revision 0)
+  (activities (%make-id-table))
+  (clients (%make-id-table))
+  (views (%make-id-table))
+  ;; A Viewset is a named, durable mapping of selected Heads to saved Views.
+  ;; It is not a current-desktop mode and never owns a lease itself.
+  (viewsets (%make-id-table))
+  (heads (%make-id-table))
+  (presentations (%make-id-table))
+  ;; Client id -> lease.  This makes duplicate visible clients impossible by
+  ;; construction.
+  (leases (%make-id-table))
+  (next-presentation-number 0))
+
+(defun make-world ()
+  "Make an empty, protocol-independent Lime model."
+  (%make-world))
+
+(defstruct activity
+  id
+  name
+  (client-ids '())
+  (view-ids '()))
+
+(defstruct client
+  id
+  activity-id
+  (shared-p nil)
+  name
+  metadata)
+
+(defstruct placement
+  "A portable request to show CLIENT-ID in a View or Presentation.
+
+KIND is currently :TILE or :FLOAT.  A floating placement's DATA is a complete
+normalized, Head-relative rectangle. DATA may also retain :TILE-WEIGHT, a
+positive relative share within a master/stack column (default 1), including
+while floating. Tiling topology lives in LAYOUT-ROOT on a View or Presentation."
+  client-id
+  (kind :tile)
+  data)
+
+(defun %validate-tile-weight (weight)
+  (unless (and (realp weight) (plusp weight))
+    (error 'invalid-transition
+           :description "A tile weight must be a positive real number."))
+  weight)
+
+(defun placement-tile-weight (placement)
+  "Return PLACEMENT's relative tiled size, defaulting to one.
+
+The weight belongs to this draft/checkpoint placement, never to the global
+client. Monocle and floating ignore it while retaining it for later tiling."
+  (let ((data (placement-data placement)))
+    (unless (and (listp data) (evenp (length data)))
+      (error 'invalid-transition
+             :description "Placement data must be a property list."))
+    (%validate-tile-weight (getf data :tile-weight 1))))
+
+(defun %data-with-tile-weight (data weight)
+  "Return independent DATA with WEIGHT, omitting the default weight of one."
+  (%validate-tile-weight weight)
+  (let ((result (copy-tree data)))
+    (if (= weight 1)
+        (remf result :tile-weight)
+        (setf (getf result :tile-weight) weight))
+    result))
+
+(defun default-floating-placement-data ()
+  "Return Lime's initial normalized rectangle for a newly floated client."
+  (list :x 1/8 :y 1/8 :width 3/4 :height 3/4))
+
+(defun %canonical-floating-placement-data (data)
+  "Validate DATA and return a complete normalized floating rectangle.
+
+Floating geometry is deliberately Head-relative so the pure model never needs
+pixel dimensions. Rectangles remain wholly inside their owning Head for this
+initial policy; a later off-screen/strut-aware layer can widen that contract."
+  (unless (or (null data)
+              (and (listp data)
+                   (evenp (length data))
+                   (loop for tail on data by #'cddr
+                         always (member (first tail) '(:x :y :width :height
+                                                       :tile-weight)))))
+    (error 'invalid-transition
+           :description "Floating placement data must be a rectangle property list."))
+  (let* ((defaults (default-floating-placement-data))
+         (x (getf data :x (getf defaults :x)))
+         (y (getf data :y (getf defaults :y)))
+         (width (getf data :width (getf defaults :width)))
+         (height (getf data :height (getf defaults :height))))
+    (unless (and (realp x) (realp y) (realp width) (realp height)
+                 (<= 0 x) (< x 1)
+                 (<= 0 y) (< y 1)
+                 (< 0 width) (<= width 1)
+                 (< 0 height) (<= height 1)
+                 (<= (+ x width) 1)
+                 (<= (+ y height) 1))
+      (error 'invalid-transition
+             :description "A floating rectangle must be positive and fit inside its Head."))
+    (%data-with-tile-weight (list :x x :y y :width width :height height)
+                            (getf data :tile-weight 1))))
+
+(defstruct layout-leaf
+  "A tiled client leaf in a Head-local binary layout tree."
+  client-id)
+
+(defstruct layout-split
+  "A binary split of FIRST and SECOND.
+
+ORIENTATION is :HORIZONTAL or :VERTICAL.  RATIO is the fraction of the usable
+output assigned to FIRST, and must be strictly between zero and one."
+  orientation
+  ratio
+  first
+  second)
+
+(defstruct view
+  id
+  activity-id
+  name
+  (placements '())
+  layout-root
+  ;; :MANUAL preserves an explicitly edited binary tree. :MASTER-STACK and
+  ;; :MONOCLE are built-in policies whose state belongs to the checkpoint too.
+  (layout-mode :manual)
+  layout-options
+  focus-client-id)
+
+(defstruct viewset-entry
+  "One saved target in a multi-Head Viewset.
+
+HEAD-ID is deliberately a durable logical identifier rather than a pixel
+rectangle. Entries may be created before a matching physical Head exists;
+activation, not saving, decides whether the current topology can satisfy it."
+  head-id
+  view-id)
+
+(defstruct viewset
+  "A named, explicit mapping from Heads to saved single-Head Views.
+
+A Viewset records only View selections. It never captures a mutable
+Presentation draft or client Lease, so recalling it follows the same explicit
+collision policy as ordinary View activation."
+  id
+  name
+  (entries '()))
+
+(defstruct head
+  "One independently addressable display rectangle. Its active Presentation is
+the only Presentation that may hold leases for this Head."
+  id
+  active-presentation-id)
+
+(defstruct presentation
+  "A mutable Activity × Head working state.
+
+SOURCE-VIEW-ID identifies the checkpoint this was recalled from; NIL denotes
+an unsaved draft.  Missing leases are recorded separately from PLACEMENTS so a
+partial activation never edits the saved checkpoint or silently erases slots."
+  id
+  head-id
+  activity-id
+  source-view-id
+  (placements '())
+  layout-root
+  (layout-mode :manual)
+  layout-options
+  focus-client-id
+  (dirty-p nil)
+  (unavailable-client-ids '()))
+
+(defstruct lease
+  client-id
+  presentation-id)
+
+(defstruct activation-conflict
+  "A preflight finding.  It is data for a menu, keybinding, REPL, or IPC client,
+not an instruction to mutate state."
+  kind
+  client-id
+  view-id
+  holder-head-id
+  holder-presentation-id)
+
+(defstruct activation-report
+  world-revision
+  head-id
+  view-id
+  source-presentation-id
+  activity-id
+  current-presentation-id
+  (desired-placements '())
+  desired-layout-root
+  (desired-layout-mode :manual)
+  desired-layout-options
+  focus-client-id
+  (conflicts '()))
+
+(defstruct activation-plan
+  base-revision
+  head-id
+  activity-id
+  source-view-id
+  target-presentation-id
+  outgoing-presentation-id
+  (desired-placements '())
+  desired-layout-root
+  (layout-mode :manual)
+  layout-options
+  focus-client-id
+  (grant-client-ids '())
+  (unavailable-client-ids '())
+  (take-client-ids '())
+  policy)
+
+(defstruct viewset-conflict
+  "One collision discovered while planning a whole Viewset activation."
+  kind
+  target-head-id
+  client-id
+  view-id
+  holder-head-id
+  holder-presentation-id)
+
+(defstruct viewset-report
+  "Read-only result of checking every target Head of one Viewset together."
+  world-revision
+  viewset-id
+  (entries '())
+  ;; (HEAD-ID . ACTIVE-PRESENTATION-ID-OR-NIL), captured for stale-plan checks.
+  (outgoing-presentation-ids '())
+  (conflicts '()))
+
+(defstruct viewset-plan
+  "A policy-selected, atomic multi-Head Viewset transition."
+  base-revision
+  viewset-id
+  policy
+  (entries '())
+  (outgoing-presentation-ids '())
+  ;; (HEAD-ID . CLIENT-IDS) for partial activation.
+  (unavailable-client-ids-by-head '())
+  ;; Client ids currently held outside the Viewset's target Heads.
+  (take-client-ids '()))
+
+(defstruct viewset-result
+  "The observable outcome of an atomic Viewset activation."
+  viewset-id
+  ;; (HEAD-ID . PRESENTATION-ID) in the Viewset's saved entry order.
+  (presentation-ids '())
+  ;; (HEAD-ID . CLIENT-IDS) omitted by partial activation, when any.
+  (unavailable-client-ids-by-head '()))
+
+(defstruct head-topology-source
+  "One removed Head with a live Presentation that needs an explicit decision."
+  head-id
+  presentation-id
+  activity-id
+  source-view-id)
+
+(defstruct head-topology-report
+  "A read-only comparison between current and desired logical Head ids."
+  world-revision
+  (current-head-ids '())
+  (desired-head-ids '())
+  (added-head-ids '())
+  (retained-head-ids '())
+  (removed-head-ids '())
+  (removed-active-sources '()))
+
+(defstruct head-topology-move
+  "Move a disappearing Head's live Presentation to a desired Head."
+  from-head-id
+  to-head-id)
+
+(defstruct head-topology-plan
+  "A checked, explicit reconciliation of the core's logical Head set."
+  base-revision
+  (current-head-ids '())
+  (desired-head-ids '())
+  (added-head-ids '())
+  (removed-head-ids '())
+  (moves '()))
+
+(defstruct head-topology-result
+  "The observable outcome of committing a Head topology plan."
+  (moved-presentation-ids '())
+  (suspended-presentation-ids '())
+  (added-head-ids '())
+  (removed-head-ids '()))
+
+(defun %touch (world)
+  (incf (world-revision world))
+  world)
+
+(defun %lookup (table id kind)
+  (or (gethash id table)
+      (error 'unknown-entity :kind kind :id id)))
+
+(defun %ensure-fresh-id (table id kind)
+  (when (gethash id table)
+    (error 'invalid-transition
+           :description (format nil "A ~A named ~S already exists." kind id))))
+
+(defun %copy-placement (placement)
+  (make-placement :client-id (placement-client-id placement)
+                  :kind (placement-kind placement)
+                  :data (if (eq (placement-kind placement) :float)
+                            (%canonical-floating-placement-data
+                             (placement-data placement))
+                            (copy-tree (placement-data placement)))))
+
+(defun %copy-placements (placements)
+  (mapcar #'%copy-placement placements))
+
+(defun %copy-layout-root (layout-root)
+  (typecase layout-root
+    (null nil)
+    (layout-leaf
+     (make-layout-leaf :client-id (layout-leaf-client-id layout-root)))
+    (layout-split
+     (make-layout-split
+      :orientation (layout-split-orientation layout-root)
+      :ratio (layout-split-ratio layout-root)
+      :first (%copy-layout-root (layout-split-first layout-root))
+      :second (%copy-layout-root (layout-split-second layout-root))))))
+
+(defun layout-node-client-ids (layout-root)
+  "Return the tiled client ids referenced by LAYOUT-ROOT, left to right."
+  (typecase layout-root
+    (null '())
+    (layout-leaf (list (layout-leaf-client-id layout-root)))
+    (layout-split (append (layout-node-client-ids (layout-split-first layout-root))
+                          (layout-node-client-ids (layout-split-second layout-root))))))
+
+(defun %placement-client-ids (placements)
+  (mapcar #'placement-client-id placements))
+
+(defun %placement-for-client (placements client-id)
+  (find client-id placements :key #'placement-client-id :test #'equal))
+
+(defun %tiled-client-ids (placements)
+  (loop for placement in placements
+        when (eq (placement-kind placement) :tile)
+          collect (placement-client-id placement)))
+
+(defun %validate-layout-node (layout-root)
+  (typecase layout-root
+    (layout-leaf
+     (unless (layout-leaf-client-id layout-root)
+       (error 'invalid-transition :description "A layout leaf needs a client id.")))
+    (layout-split
+     (unless (member (layout-split-orientation layout-root)
+                     '(:horizontal :vertical))
+       (error 'invalid-transition
+              :description "A layout split must be :HORIZONTAL or :VERTICAL."))
+     (unless (and (realp (layout-split-ratio layout-root))
+                  (< 0 (layout-split-ratio layout-root) 1))
+       (error 'invalid-transition
+              :description "A layout split ratio must be strictly between zero and one."))
+     (unless (and (layout-split-first layout-root)
+                  (layout-split-second layout-root))
+       (error 'invalid-transition
+              :description "A layout split needs two child nodes."))
+     (%validate-layout-node (layout-split-first layout-root))
+     (%validate-layout-node (layout-split-second layout-root)))
+    (otherwise
+     (error 'invalid-transition :description "Unknown layout node."))))
+
+(defun %same-id-set-p (left right)
+  (and (= (length left) (length right))
+       (every (lambda (id) (member id right :test #'equal)) left)))
+
+(defun %validate-layout-root (world activity-id placements layout-root)
+  (when layout-root
+    (%validate-layout-node layout-root)
+    (let ((layout-client-ids (layout-node-client-ids layout-root))
+          (tiled-client-ids (%tiled-client-ids placements)))
+      (unless (= (length layout-client-ids)
+                 (length (remove-duplicates layout-client-ids :test #'equal)))
+        (error 'invalid-transition
+               :description "A layout tree may not contain the same client twice."))
+      (unless (%same-id-set-p layout-client-ids tiled-client-ids)
+        (error 'invalid-transition
+               :description
+               "A layout tree must contain exactly the tiled clients in its placements."))
+      (dolist (client-id layout-client-ids)
+        (%ensure-client-in-activity world client-id activity-id)))))
+
+(defun %validate-layout-mode (layout-mode layout-options)
+  "Check the stable, backend-neutral layout-policy vocabulary.
+
+Detailed option interpretation belongs to the pure layout module; this layer
+only guarantees that checkpoints and plans carry an ordinary property list."
+  (unless (member layout-mode '(:manual :master-stack :monocle))
+    (error 'invalid-transition
+           :description "A layout mode must be :MANUAL, :MASTER-STACK, or :MONOCLE."))
+  (unless (and (listp layout-options)
+               (evenp (length layout-options))
+               (loop for tail on layout-options by #'cddr
+                     always (keywordp (first tail))))
+    (error 'invalid-transition
+           :description "Layout options must be a keyword property list."))
+  (when (and layout-options (not (eq layout-mode :master-stack)))
+    (error 'invalid-transition
+           :description "Only :MASTER-STACK accepts layout options."))
+  (when (eq layout-mode :master-stack)
+    (unless (every (lambda (key)
+                     (member key '(:master-count :master-ratio :orientation)))
+                   (loop for (key) on layout-options by #'cddr collect key))
+      (error 'invalid-transition
+             :description "Unknown master/stack layout option."))
+    (let ((master-count (getf layout-options :master-count 1))
+          (master-ratio (getf layout-options :master-ratio 3/5))
+          (orientation (getf layout-options :orientation :horizontal)))
+      (unless (and (integerp master-count) (plusp master-count))
+        (error 'invalid-transition
+               :description "Master/stack :MASTER-COUNT must be a positive integer."))
+      (unless (and (realp master-ratio) (< 0 master-ratio 1))
+        (error 'invalid-transition
+               :description "Master/stack :MASTER-RATIO must be strictly between zero and one."))
+      (unless (member orientation '(:horizontal :vertical))
+        (error 'invalid-transition
+               :description "Master/stack :ORIENTATION must be :HORIZONTAL or :VERTICAL.")))))
+
+(defun %add-unique-id (id ids)
+  (if (member id ids :test #'equal)
+      ids
+      (append ids (list id))))
+
+(defun %remove-id (id ids)
+  (remove id ids :test #'equal))
+
+(defun find-activity (world id)
+  (%lookup (world-activities world) id :activity))
+
+(defun find-client (world id)
+  (%lookup (world-clients world) id :client))
+
+(defun find-view (world id)
+  (%lookup (world-views world) id :view))
+
+(defun find-viewset (world id)
+  (%lookup (world-viewsets world) id :viewset))
+
+(defun find-head (world id)
+  (%lookup (world-heads world) id :head))
+
+(defun find-presentation (world id)
+  (%lookup (world-presentations world) id :presentation))
+
+(defun list-activities (world)
+  "Return every Activity currently registered in WORLD.
+
+The core deliberately promises membership rather than an ordering; a UI can
+sort stable display labels according to its own presentation policy."
+  (let (activities)
+    (maphash (lambda (id activity)
+               (declare (ignore id))
+               (push activity activities))
+             (world-activities world))
+    activities))
+
+(defun list-viewsets (world)
+  "Return every durable Viewset currently registered in WORLD.
+
+Like LIST-ACTIVITIES, this deliberately makes no ordering promise; a frontend
+sorts display labels according to its own presentation policy."
+  (let (viewsets)
+    (maphash (lambda (id viewset)
+               (declare (ignore id))
+               (push viewset viewsets))
+             (world-viewsets world))
+    viewsets))
+
+(defun current-presentation (world head-id)
+  "Return HEAD-ID's active presentation, or NIL when it is blank."
+  (let ((presentation-id (head-active-presentation-id (find-head world head-id))))
+    (and presentation-id (find-presentation world presentation-id))))
+
+(defun lease-for-client (world client-id)
+  (gethash client-id (world-leases world)))
+
+(defun presentation-client-ids (presentation)
+  (%placement-client-ids (presentation-placements presentation)))
+
+(defun client-available-in-activity-p (world client-id activity-id)
+  "Sharing grants eligibility, never a lease. Every client still has one home."
+  (find-activity world activity-id)
+  (let ((client (find-client world client-id)))
+    (or (client-shared-p client) (equal (client-activity-id client) activity-id))))
+
+(defun activity-available-client-ids (world activity-id)
+  "Home clients followed by shared guests, with no duplicate ids."
+  (let ((home (activity-client-ids (find-activity world activity-id))))
+    (append (copy-list home)
+            (sort (loop for client being the hash-values of (world-clients world)
+                        when (and (client-shared-p client)
+                                  (not (equal (client-activity-id client) activity-id)))
+                          collect (client-id client))
+                  #'string< :key #'princ-to-string))))
+
+(defun presentation-hidden-client-ids (world presentation)
+  "Return eligible home/shared clients omitted from PRESENTATION's placements.
+
+An Activity owns its clients independently of any one Head-local draft or
+saved View.  Thus a hidden client remains alive and available to a later
+`SHOW-CLIENT-ON-PRESENTATION` call; it is neither minimized nor removed from
+the Activity.  A client with an unavailable placement is intentionally not in
+this result: the Presentation already asks for that slot and may reclaim it
+once its lease becomes free."
+  (let ((shown-client-ids (presentation-client-ids presentation)))
+    (loop for client-id in (activity-available-client-ids world (presentation-activity-id presentation))
+          unless (member client-id shown-client-ids :test #'equal)
+            collect client-id)))
+
+(defun presentation-active-p (world presentation)
+  ;; A topology reconciliation can suspend a cached draft from a removed
+  ;; Head.  Such a Presentation has no HEAD-ID until an explicit later resume
+  ;; binds it to a real Head again, and it must never be considered active.
+  (let ((head-id (presentation-head-id presentation)))
+    (and head-id
+         (let ((head (gethash head-id (world-heads world))))
+           (and head
+                (equal (head-active-presentation-id head)
+                       (presentation-id presentation)))))))
+
+(defun presentation-leased-client-ids (world presentation)
+  "Return the clients currently visible in PRESENTATION, in layout order."
+  (loop for placement in (presentation-placements presentation)
+        for client-id = (placement-client-id placement)
+        for lease = (lease-for-client world client-id)
+        when (and lease
+                  (equal (lease-presentation-id lease)
+                         (presentation-id presentation)))
+          collect client-id))
+
+(defun create-head (world id)
+  "Register a Head. It starts with no active Presentation."
+  (%ensure-fresh-id (world-heads world) id :head)
+  (setf (gethash id (world-heads world)) (make-head :id id))
+  (%touch world)
+  (find-head world id))
+
+(defun create-activity (world id name)
+  "Create a durable task container."
+  (%ensure-fresh-id (world-activities world) id :activity)
+  (setf (gethash id (world-activities world))
+        (make-activity :id id :name name))
+  (%touch world)
+  (find-activity world id))
+
+(defun create-client (world id activity-id &key name metadata (shared-p nil))
+  "Create a client in ACTIVITY-ID's pool.  It is parked until a presentation
+explicitly asks to show it."
+  (%ensure-fresh-id (world-clients world) id :client)
+  (unless (member shared-p '(nil t))
+    (error 'invalid-transition :description "SHARED-P must be T or NIL."))
+  (let ((activity (find-activity world activity-id)))
+    (setf (gethash id (world-clients world))
+          (make-client :id id
+                       :activity-id activity-id
+                       :shared-p shared-p
+                       :name name
+                       :metadata metadata))
+    (setf (activity-client-ids activity)
+          (%add-unique-id id (activity-client-ids activity)))
+    (%touch world)
+    (find-client world id)))
+
+(defun %ensure-client-in-activity (world client-id activity-id)
+  (let ((client (find-client world client-id)))
+    (unless (client-available-in-activity-p world client-id activity-id)
+      (error 'invalid-activity-membership
+             :client-id client-id
+             :activity-id activity-id))
+    client))
+
+(defun %validate-placements (world activity-id placements)
+  (unless (every (lambda (placement) (typep placement 'placement)) placements)
+    (error 'invalid-transition :description "A view placement was not a PLACEMENT."))
+  (dolist (placement placements)
+    (placement-tile-weight placement)
+    (unless (member (placement-kind placement) '(:tile :float))
+      (error 'invalid-transition
+             :description "A placement kind must be :TILE or :FLOAT."))
+    (when (eq (placement-kind placement) :float)
+      (%canonical-floating-placement-data (placement-data placement))))
+  (let ((client-ids (%placement-client-ids placements)))
+    (unless (= (length client-ids)
+               (length (remove-duplicates client-ids :test #'equal)))
+      (error 'invalid-transition
+             :description "A layout may not contain the same client twice."))
+    (dolist (client-id client-ids)
+      (%ensure-client-in-activity world client-id activity-id))))
+
+(defun %activity-has-view-named-p (world activity name)
+  "Whether ACTIVITY already owns a View with human-facing NAME.
+
+View ids are machine identities, but `Activity:View` is Lime's human-facing
+address.  Case-insensitive uniqueness within that Activity keeps menus,
+commands, and spoken names unambiguous while allowing every other Activity to
+have its own `Inbox`, `Code`, or `Debug` checkpoint."
+  (loop for view-id in (activity-view-ids activity)
+        for view = (find-view world view-id)
+        thereis (equalp name (view-name view))))
+
+(defun create-view (world id activity-id name placements
+                    &key layout-root (layout-mode :manual) layout-options
+                      focus-client-id)
+  "Save a named, single-Head checkpoint.
+
+PLACEMENTS contains only windows the View requests to display.  A client absent
+from a View is not globally hidden; another Head may still lease it."
+  (%ensure-fresh-id (world-views world) id :view)
+  (let ((activity (find-activity world activity-id)))
+    (when (%activity-has-view-named-p world activity name)
+      (error 'invalid-transition
+             :description
+             (format nil "Activity ~S already has a View named ~S."
+                     activity-id name)))
+    (%validate-placements world activity-id placements)
+    (%validate-layout-root world activity-id placements layout-root)
+    (%validate-layout-mode layout-mode layout-options)
+    (when focus-client-id
+      (%ensure-client-in-activity world focus-client-id activity-id))
+    (setf (gethash id (world-views world))
+          (make-view :id id
+                     :activity-id activity-id
+                     :name name
+                     :placements (%copy-placements placements)
+                     :layout-root (%copy-layout-root layout-root)
+                     :layout-mode layout-mode
+                     :layout-options (copy-tree layout-options)
+                     :focus-client-id focus-client-id))
+    (setf (activity-view-ids activity)
+          (%add-unique-id id (activity-view-ids activity)))
+    (%touch world)
+    (find-view world id)))
+
+(defun %copy-viewset-entries (entries)
+  (mapcar (lambda (entry)
+            (make-viewset-entry :head-id (viewset-entry-head-id entry)
+                                :view-id (viewset-entry-view-id entry)))
+          entries))
+
+(defun %validate-viewset-entries (world entries)
+  "Validate a durable Head -> View mapping without requiring current Heads.
+
+The saved mapping may outlive a dock, laptop panel, or temporary monitor. A
+missing physical Head is therefore an activation-time error, not a reason to
+reject the useful named shortcut at save time."
+  (unless (and (listp entries) entries
+               (every (lambda (entry) (typep entry 'viewset-entry)) entries))
+    (error 'invalid-transition
+           :description "A Viewset needs at least one VIEWSET-ENTRY."))
+  (let ((head-ids (mapcar #'viewset-entry-head-id entries))
+        (view-ids (mapcar #'viewset-entry-view-id entries)))
+    (unless (and (every #'identity head-ids)
+                 (= (length head-ids)
+                    (length (remove-duplicates head-ids :test #'equal))))
+      (error 'invalid-transition
+             :description "A Viewset may name each Head only once."))
+    (unless (and (every #'identity view-ids)
+                 (= (length view-ids)
+                    (length (remove-duplicates view-ids :test #'equal))))
+      (error 'invalid-transition
+             :description "A Viewset may mount each named View only once."))
+    (dolist (view-id view-ids)
+      (find-view world view-id)))
+  entries)
+
+(defun create-viewset (world id name entries)
+  "Save NAME as an explicit mapping of logical Heads to named Views.
+
+The operation does not activate anything and does not capture mutable live
+drafts. Use the Viewset planner to decide the later multi-Head recall policy."
+  (%ensure-fresh-id (world-viewsets world) id :viewset)
+  (%validate-viewset-entries world entries)
+  (setf (gethash id (world-viewsets world))
+        (make-viewset :id id :name name :entries (%copy-viewset-entries entries)))
+  (%touch world)
+  (find-viewset world id))

src/package.lisp

@@ -0,0 +1,256 @@
+(defpackage #:lime.core
+  (:use #:cl)
+  (:documentation
+   "The protocol-independent Activity/View/Head/Lease model used by Lime.")
+  (:export
+   ;; Conditions
+   #:lime-error
+   #:unknown-entity
+   #:unknown-entity-kind
+   #:unknown-entity-id
+   #:invalid-activity-membership
+   #:invalid-activity-membership-client-id
+   #:invalid-activity-membership-activity-id
+   #:activation-blocked
+   #:activation-blocked-report
+   #:stale-transition-plan
+   #:degraded-presentation-update
+   #:invalid-transition
+
+   ;; Data types and accessors useful to the UI/backend layer.
+   #:world
+   #:make-world
+   #:normalize-activity-arrangements
+   #:world-revision
+   #:activity
+   #:activity-id
+   #:activity-name
+   #:activity-client-ids
+   #:activity-view-ids
+   #:client
+   #:client-id
+   #:client-activity-id
+   #:client-shared-p
+   #:client-available-in-activity-p
+   #:activity-available-client-ids
+   #:client-name
+   #:client-metadata
+   #:placement
+   #:make-placement
+   #:placement-client-id
+   #:placement-kind
+   #:placement-data
+   #:placement-tile-weight
+   #:default-floating-placement-data
+   #:layout-leaf
+   #:make-layout-leaf
+   #:layout-leaf-client-id
+   #:layout-split
+   #:make-layout-split
+   #:layout-split-orientation
+   #:layout-split-ratio
+   #:layout-split-first
+   #:layout-split-second
+   #:layout-node-client-ids
+   #:geometry
+   #:make-geometry
+   #:geometry-x
+   #:geometry-y
+   #:geometry-width
+   #:geometry-height
+   #:default-layout-root
+   #:master-stack-layout-root
+   #:resolve-presentation-layout
+   #:view
+   #:view-id
+   #:view-activity-id
+   #:view-name
+   #:view-placements
+   #:view-layout-root
+   #:view-layout-mode
+   #:view-layout-options
+   #:view-focus-client-id
+   #:viewset-entry
+   #:make-viewset-entry
+   #:viewset-entry-head-id
+   #:viewset-entry-view-id
+   #:viewset
+   #:viewset-id
+   #:viewset-name
+   #:viewset-entries
+   #:head
+   #:head-id
+   #:head-active-presentation-id
+   #:presentation
+   #:presentation-id
+   #:presentation-head-id
+   #:presentation-activity-id
+   #:presentation-source-view-id
+   #:presentation-placements
+   #:presentation-layout-root
+   #:presentation-layout-mode
+   #:presentation-layout-options
+   #:presentation-focus-client-id
+   #:presentation-dirty-p
+   #:presentation-unavailable-client-ids
+   #:lease
+   #:lease-client-id
+   #:lease-presentation-id
+   #:activation-conflict
+   #:activation-conflict-kind
+   #:activation-conflict-client-id
+   #:activation-conflict-view-id
+   #:activation-conflict-holder-head-id
+   #:activation-conflict-holder-presentation-id
+   #:activation-report
+   #:activation-report-world-revision
+   #:activation-report-head-id
+   #:activation-report-view-id
+   #:activation-report-source-presentation-id
+   #:activation-report-activity-id
+   #:activation-report-current-presentation-id
+   #:activation-report-desired-placements
+   #:activation-report-desired-layout-root
+   #:activation-report-desired-layout-mode
+   #:activation-report-desired-layout-options
+   #:activation-report-focus-client-id
+   #:activation-report-conflicts
+   #:activation-plan
+   #:activation-plan-policy
+   #:activation-plan-layout-mode
+   #:activation-plan-layout-options
+   #:viewset-conflict
+   #:viewset-conflict-kind
+   #:viewset-conflict-target-head-id
+   #:viewset-conflict-client-id
+   #:viewset-conflict-view-id
+   #:viewset-conflict-holder-head-id
+   #:viewset-conflict-holder-presentation-id
+   #:viewset-report
+   #:viewset-report-world-revision
+   #:viewset-report-viewset-id
+   #:viewset-report-entries
+   #:viewset-report-outgoing-presentation-ids
+   #:viewset-report-conflicts
+   #:viewset-plan
+   #:viewset-plan-policy
+   #:viewset-result
+   #:viewset-result-viewset-id
+   #:viewset-result-presentation-ids
+   #:viewset-result-unavailable-client-ids-by-head
+   #:head-topology-source
+   #:head-topology-source-head-id
+   #:head-topology-source-presentation-id
+   #:head-topology-source-activity-id
+   #:head-topology-source-source-view-id
+   #:head-topology-report
+   #:head-topology-report-world-revision
+   #:head-topology-report-current-head-ids
+   #:head-topology-report-desired-head-ids
+   #:head-topology-report-added-head-ids
+   #:head-topology-report-retained-head-ids
+   #:head-topology-report-removed-head-ids
+   #:head-topology-report-removed-active-sources
+   #:head-topology-move
+   #:make-head-topology-move
+   #:head-topology-move-from-head-id
+   #:head-topology-move-to-head-id
+   #:head-topology-plan
+   #:head-topology-plan-base-revision
+   #:head-topology-plan-current-head-ids
+   #:head-topology-plan-desired-head-ids
+   #:head-topology-plan-added-head-ids
+   #:head-topology-plan-removed-head-ids
+   #:head-topology-plan-moves
+   #:head-topology-result
+   #:head-topology-result-moved-presentation-ids
+   #:head-topology-result-suspended-presentation-ids
+   #:head-topology-result-added-head-ids
+   #:head-topology-result-removed-head-ids
+
+   ;; Queries.
+   #:find-activity
+   #:find-client
+   #:find-view
+   #:find-viewset
+   #:find-head
+   #:find-presentation
+   #:list-activities
+   #:activity-deletion-summary
+   #:list-viewsets
+   #:current-presentation
+   #:activity-draft-for-head
+   #:lease-for-client
+   #:presentation-client-ids
+   #:presentation-leased-client-ids
+   #:presentation-hidden-client-ids
+   #:presentation-active-p
+   #:activation-report-ready-p
+   #:viewset-report-ready-p
+
+   ;; Model construction.
+   #:create-head
+   #:create-activity
+   #:delete-activity
+   #:create-client
+   #:move-client-to-activity
+   #:move-client-to-presentation
+   #:set-client-shared
+   #:make-client-private-in-presentation
+   #:create-view
+   #:create-viewset
+
+   ;; Planning and transitions.
+   #:preflight-view-activation
+   #:preflight-presentation-resume
+   #:activity-presentations
+   #:preflight-presentation-bring
+   #:bring-presentation-to-head
+   #:preflight-activity-draft
+   #:preflight-viewset-activation
+   #:preflight-head-topology-reconciliation
+   #:build-strict-activation-plan
+   #:build-partial-activation-plan
+   #:build-taking-activation-plan
+   #:commit-activation-plan
+   #:build-strict-viewset-plan
+   #:build-partial-viewset-plan
+   #:build-taking-viewset-plan
+   #:commit-viewset-plan
+   #:build-head-topology-reconciliation-plan
+   #:commit-head-topology-reconciliation-plan
+   #:activate-view-strictly
+   #:activate-view-partially
+   #:activate-view-taking
+   #:activate-viewset-strictly
+   #:activate-viewset-partially
+   #:activate-viewset-taking
+   #:resume-presentation-strictly
+   #:resume-presentation-partially
+   #:resume-presentation-taking
+   #:open-activity-draft
+   #:retire-client
+   #:transfer-client-lease
+   #:reclaim-available-slots
+   #:show-client-on-presentation
+   #:hide-client-from-presentation
+   #:hide-focused-client-in-presentation
+   #:focus-client-on-presentation
+   #:set-presentation-layout-root
+   #:set-presentation-layout-mode
+   #:set-presentation-master-stack-layout
+   #:set-presentation-monocle-layout
+   #:set-presentation-manual-layout
+   #:set-client-tile-weight
+   #:set-focused-layout-split-orientation
+   #:adjust-focused-layout-split-ratio
+   #:swap-presentation-layout-clients
+   #:swap-focused-layout-client
+   #:promote-client-to-master
+   #:presentation-client-floating-p
+   #:toggle-client-floating
+   #:toggle-focused-client-floating
+   #:set-client-floating-geometry
+   #:update-view-from-presentation
+   #:save-view-from-presentation
+   #:validate-world))

src/persistence/model.lisp

@@ -0,0 +1,246 @@
+(in-package #:lime.persistence)
+
+;;;; Versioned plain data, independent of X11, disk I/O, and Lisp object layouts.
+
+(defun check-data (data)
+  "Accept only bounded, acyclic data. Never serialize functions or live objects."
+  (let ((path (make-hash-table :test #'eq)) (remaining 200000)
+        (stack (list (list data 0 nil))))
+    ;; Explicit traversal keeps a broad untrusted list off the Lisp call stack.
+    (loop while stack do
+      (destructuring-bind (value depth exit-p) (pop stack)
+        (if exit-p
+            (remhash value path)
+            (progn
+              (when (or (minusp (decf remaining)) (> depth 128))
+                (error "Session data exceeds its size/depth limit."))
+              (typecase value
+                (cons
+                 (when (gethash value path) (error "Circular session data."))
+                 (setf (gethash value path) t)
+                 (push (list value depth t) stack)
+                 (push (list (cdr value) depth nil) stack)
+                 (push (list (car value) (1+ depth) nil) stack))
+                (null nil)
+                (string (when (> (length value) 32768) (error "Session string is too long.")))
+                (symbol (unless (or (eq value t) (keywordp value))
+                          (error "Unsupported session symbol ~S." value)))
+                (rational (when (> (max (integer-length (numerator value))
+                                        (integer-length (denominator value))) 256)
+                            (error "Session number is too large.")))
+                (float (unless (<= (- most-positive-double-float) value most-positive-double-float)
+                         (error "Session number must be finite.")))
+                (otherwise (error "Unsupported session value of type ~S." (type-of value)))))))))
+  data)
+
+(defun copy-data (data)
+  "Freeze data for a worker, including mutable strings (COPY-TREE alone doesn't)."
+  (check-data data)
+  (labels ((clone (value)
+             (cond
+               ((stringp value) (copy-seq value))
+               ((consp value)
+                (let* ((result (cons nil nil)) (tail result) (source value))
+                  (loop
+                    (setf (car tail) (clone (car source)))
+                    (if (consp (cdr source))
+                        (setf (cdr tail) (cons nil nil) tail (cdr tail) source (cdr source))
+                        (progn (setf (cdr tail) (clone (cdr source))) (return result))))))
+               (t value))))
+    (clone data)))
+
+(defun check-record (data keys)
+  "Require an exact, non-duplicated keyword schema (also rejects dotted lists)."
+  (unless (and (listp data) (evenp (list-length data))
+               (= (length data) (* 2 (length keys)))
+               (equal (sort (loop for tail on data by #'cddr collect (car tail))
+                            #'string< :key #'symbol-name)
+                      (sort (copy-list keys) #'string< :key #'symbol-name)))
+    (error "Malformed session record; expected fields ~S." keys))
+  data)
+
+(defun %id (value &optional nullable)
+  (unless (or (and nullable (null value))
+              (and (stringp value) (plusp (length value)))
+              (and value (keywordp value)) (integerp value))
+    (error "Invalid session identifier ~S." value))
+  value)
+
+(defun %name (value)
+  (unless (stringp value) (error "Session names must be strings.")) value)
+
+(defun %boolean (value)
+  (unless (member value '(t nil)) (error "Invalid session boolean ~S." value)) value)
+
+(defun %rows (table function)
+  (mapcar (lambda (id) (funcall function (gethash id table)))
+          (sort (loop for id being the hash-keys of table collect id)
+                #'string< :key #'prin1-to-string)))
+
+(defun %tree-data (node)
+  (etypecase node
+    (null nil)
+    (layout-leaf (list :leaf (layout-leaf-client-id node)))
+    (layout-split (list :split (layout-split-orientation node) (layout-split-ratio node)
+                       (%tree-data (layout-split-first node))
+                       (%tree-data (layout-split-second node))))))
+
+(defun %restore-tree (data)
+  (cond ((null data) nil)
+        ((and (listp data) (eq (first data) :leaf) (= 2 (length data)))
+         (make-layout-leaf :client-id (%id (second data))))
+        ((and (listp data) (eq (first data) :split) (= 5 (length data)))
+         (make-layout-split :orientation (second data) :ratio (third data)
+                            :first (%restore-tree (fourth data)) :second (%restore-tree (fifth data))))
+        (t (error "Malformed saved layout tree."))))
+
+(defun %placement-data (placements)
+  (mapcar (lambda (placement)
+            (list :client (placement-client-id placement) :kind (placement-kind placement)
+                  :data (copy-tree (check-data (placement-data placement))))) placements))
+
+(defun %restore-placements (data)
+  (mapcar (lambda (row)
+            (check-record row '(:client :kind :data))
+            (make-placement :client-id (%id (getf row :client)) :kind (getf row :kind)
+                            :data (copy-tree (getf row :data)))) data))
+
+(defun snapshot-world (world)
+  "Capture model data, not leases, X resources, configuration, or executable code."
+  (validate-world world)
+  (copy-data
+   (list :format :lime-world :version 3 :revision (world-revision world)
+         :next-presentation-number (lime.core::world-next-presentation-number world)
+         :activities (%rows (lime.core::world-activities world)
+                            (lambda (a) (list :id (activity-id a) :name (activity-name a)
+                                              :clients (copy-list (activity-client-ids a))
+                                              :views (copy-list (activity-view-ids a)))))
+         :clients (%rows (lime.core::world-clients world)
+                         (lambda (c) (list :id (client-id c) :activity (client-activity-id c)
+                                           :name (client-name c) :shared (client-shared-p c)
+                                           :metadata (copy-tree (check-data (client-metadata c))))))
+         :views (%rows (lime.core::world-views world)
+                       (lambda (v) (list :id (view-id v) :activity (view-activity-id v) :name (view-name v)
+                                         :placements (%placement-data (view-placements v))
+                                         :tree (%tree-data (view-layout-root v)) :layout (view-layout-mode v)
+                                         :options (copy-tree (view-layout-options v)) :focus (view-focus-client-id v))))
+         :viewsets (%rows (lime.core::world-viewsets world)
+                          (lambda (v) (list :id (viewset-id v) :name (viewset-name v)
+                                            :entries (mapcar (lambda (e) (list (viewset-entry-head-id e)
+                                                                               (viewset-entry-view-id e)))
+                                                             (viewset-entries v)))))
+         :heads (%rows (lime.core::world-heads world)
+                       (lambda (h) (list :id (head-id h) :active (head-active-presentation-id h))))
+         :presentations
+         (%rows (lime.core::world-presentations world)
+                (lambda (p) (list :id (presentation-id p) :head (presentation-head-id p)
+                                  :activity (presentation-activity-id p) :source (presentation-source-view-id p)
+                                  :placements (%placement-data (presentation-placements p))
+                                  :tree (%tree-data (presentation-layout-root p)) :layout (presentation-layout-mode p)
+                                  :options (copy-tree (presentation-layout-options p))
+                                  :focus (presentation-focus-client-id p) :dirty (presentation-dirty-p p)
+                                  :unavailable (copy-list (presentation-unavailable-client-ids p))))))))
+
+(defun %distinct-subset (ids all)
+  (and (listp ids) (= (length ids) (length (remove-duplicates ids :test #'equal)))
+       (every (lambda (id) (member id all :test #'equal)) ids)))
+
+(defun restore-world (data &key (normalize-arrangements-p t))
+  "Build and validate a fresh candidate. Never mutate the live world on failure."
+  (check-data data)
+  (check-record data '(:format :version :revision :next-presentation-number :activities :clients
+                       :views :viewsets :heads :presentations))
+  (unless (and (eq :lime-world (getf data :format)) (member (getf data :version) '(1 2 3)))
+    (error "Unsupported Lime world format/version."))
+  (dolist (key '(:revision :next-presentation-number))
+    (unless (typep (getf data key) '(integer 0 *)) (error "Invalid session counter ~S." key)))
+  (let ((world (make-world)))
+    (dolist (row (getf data :activities))
+      (check-record row '(:id :name :clients :views))
+      (create-activity world (%id (getf row :id)) (%name (getf row :name))))
+    (dolist (row (getf data :clients))
+      (check-record row (if (eql 1 (getf data :version))
+                            '(:id :activity :name :metadata)
+                            '(:id :activity :name :metadata :shared)))
+      (unless (or (null (getf row :name)) (stringp (getf row :name)))
+        (error "Invalid saved client name."))
+      (create-client world (%id (getf row :id)) (%id (getf row :activity))
+                     :name (getf row :name) :metadata (copy-tree (getf row :metadata))
+                     :shared-p (%boolean (getf row :shared))))
+    (dolist (row (getf data :views))
+      (check-record row '(:id :activity :name :placements :tree :layout :options :focus))
+      (create-view world (%id (getf row :id)) (%id (getf row :activity)) (%name (getf row :name))
+                   (%restore-placements (getf row :placements))
+                   :layout-root (%restore-tree (getf row :tree)) :layout-mode (getf row :layout)
+                   :layout-options (getf row :options) :focus-client-id (%id (getf row :focus) t)))
+    ;; Preserve Activity pool/library order while rejecting missing/foreign ids.
+    (dolist (row (getf data :activities))
+      (let ((activity (find-activity world (getf row :id))))
+        (dolist (pair (list (cons :clients (activity-client-ids activity))
+                           (cons :views (activity-view-ids activity))))
+          (unless (and (%distinct-subset (getf row (car pair)) (cdr pair))
+                       (= (length (getf row (car pair))) (length (cdr pair))))
+            (error "Invalid saved Activity membership.")))
+        (setf (activity-client-ids activity) (copy-list (getf row :clients))
+              (activity-view-ids activity) (copy-list (getf row :views)))))
+    (dolist (row (getf data :viewsets))
+      (check-record row '(:id :name :entries))
+      (create-viewset world (%id (getf row :id)) (%name (getf row :name))
+                      (mapcar (lambda (e)
+                                (unless (= 2 (length e)) (error "Malformed Viewset entry."))
+                                (make-viewset-entry :head-id (%id (first e)) :view-id (%id (second e))))
+                              (getf row :entries))))
+    (dolist (row (getf data :heads))
+      (check-record row '(:id :active))
+      (setf (head-active-presentation-id (create-head world (%id (getf row :id))))
+            (%id (getf row :active) t)))
+    (dolist (row (getf data :presentations))
+      (check-record row '(:id :head :activity :source :placements :tree :layout :options :focus :dirty :unavailable))
+      (let* ((id (%id (getf row :id))) (activity (%id (getf row :activity)))
+             (placements (%restore-placements (getf row :placements)))
+             (tree (%restore-tree (getf row :tree))) (source (%id (getf row :source) t))
+             (focus (%id (getf row :focus) t)) (unavailable (getf row :unavailable)))
+        (lime.core::%ensure-fresh-id (lime.core::world-presentations world) id :presentation)
+        (find-activity world activity)
+        (lime.core::%validate-placements world activity placements)
+        (lime.core::%validate-layout-root world activity placements tree)
+        (lime.core::%validate-layout-mode (getf row :layout) (getf row :options))
+        (when (and source (not (equal activity (view-activity-id (find-view world source)))))
+          (error "Presentation references a View from another Activity."))
+        (when (and focus (not (find focus placements :key #'placement-client-id :test #'equal)))
+          (error "Presentation focus has no placement."))
+        (unless (%distinct-subset unavailable (mapcar #'placement-client-id placements))
+          (error "Invalid unavailable-client list."))
+        (setf (gethash id (lime.core::world-presentations world))
+              (lime.core::make-presentation
+               :id id :head-id (%id (getf row :head) t) :activity-id activity :source-view-id source
+               :placements placements :layout-root tree :layout-mode (getf row :layout)
+               :layout-options (copy-tree (getf row :options)) :focus-client-id focus
+               :dirty-p (%boolean (getf row :dirty)) :unavailable-client-ids (copy-list unavailable)))))
+    ;; Leases are derived, not deserialized authority. Conflicting grants fail.
+    (maphash (lambda (id head)
+               (declare (ignore id))
+               (when (head-active-presentation-id head)
+                 (let ((p (find-presentation world (head-active-presentation-id head))))
+                   (dolist (client (set-difference (presentation-client-ids p)
+                                                  (presentation-unavailable-client-ids p) :test #'equal))
+                     (when (lease-for-client world client) (error "Saved Heads request duplicate leases."))
+                     (setf (gethash client (lime.core::world-leases world))
+                           (lime.core::make-lease :client-id client :presentation-id (presentation-id p)))))))
+             (lime.core::world-heads world))
+    (setf (lime.core::world-next-presentation-number world) (getf data :next-presentation-number)
+          (lime.core::world-revision world) (getf data :revision))
+    ;; Protect future generated ids even for snapshots edited by hand.
+    (maphash (lambda (id p)
+               (declare (ignore p))
+               (when (and (stringp id) (uiop:string-prefix-p "presentation-" id))
+                 (let ((number (ignore-errors (parse-integer id :start 13))))
+                   (when number
+                     (setf (lime.core::world-next-presentation-number world)
+                           (max number (lime.core::world-next-presentation-number world)))))))
+             (lime.core::world-presentations world))
+    (validate-world world :legacy-p (< (getf data :version) 3))
+    (when (and normalize-arrangements-p (< (getf data :version) 3))
+      (normalize-activity-arrangements world)
+      (validate-world world))
+    world))

src/persistence/package.lisp

@@ -0,0 +1,6 @@
+(defpackage #:lime.persistence
+  (:use #:cl #:lime.core)
+  (:export #:snapshot-world #:restore-world #:check-data #:copy-data #:check-record
+           #:session-store #:open-session-store #:close-session-store
+           #:session-store-path #:read-session-store #:write-session-store
+           #:default-session-path))

src/persistence/store.lisp

@@ -0,0 +1,122 @@
+(in-package #:lime.persistence)
+
+;;;; Linux storage boundary: one lifetime writer lock, private temp + fsync +
+;;;; atomic rename. The previous file is untouched until a complete write wins.
+
+(defstruct (session-store (:constructor %make-session-store)) path descriptor)
+
+(defun default-session-path (display-name)
+  "Separate actual/nested X displays without depending on a Lime environment variable."
+  (merge-pathnames
+   (format nil "lime/sessions/display-~A.sexp"
+           (with-output-to-string (out)
+             (loop for c across (or display-name "default")
+                   do (if (or (alphanumericp c) (find c ".-"))
+                          (write-char c out) (format out "_~2,'0X" (char-code c))))))
+   (uiop:ensure-directory-pathname
+    (or (let ((path (uiop:getenv "XDG_STATE_HOME")))
+          (and path (plusp (length path)) path))
+        (merge-pathnames ".local/state/" (user-homedir-pathname))))))
+
+(defun %private-file (path)
+  (unless (zerop (cffi:foreign-funcall "chmod" :string (namestring path) :unsigned-int #o600 :int))
+    (error "Cannot make session file private: ~A" path)))
+
+(defun open-session-store (path)
+  "Claim one writer for PATH; another Lime using it must not overwrite this desk."
+  (let* ((path (merge-pathnames (pathname path) (uiop:getcwd)))
+         (lock (pathname (concatenate 'string (namestring path) ".lock"))))
+    (when (or (wild-pathname-p path) (null (pathname-name path)))
+      (error "Session path must name one file without wildcards."))
+    (ensure-directories-exist path)
+    ;; O_RDWR | O_CREAT | O_CLOEXEC, Linux. Lock files are kept: unlinking a
+    ;; held lock would let two different inodes each claim the same path.
+    (let ((fd (cffi:foreign-funcall "open" :string (namestring lock)
+                                  :int (logior 2 #o100 #o2000000) :unsigned-int #o600 :int)))
+      (when (minusp fd) (error "Cannot open session lock: ~A" lock))
+      (handler-case
+          (progn
+            (%private-file lock)
+            (unless (zerop (cffi:foreign-funcall "flock" :int fd :int (logior 2 4) :int))
+              (error "Session file is already owned by another Lime: ~A" path))
+            (%make-session-store :path path :descriptor fd))
+        (error (c)
+          (cffi:foreign-funcall "close" :int fd :int)
+          (error c))))))
+
+(defun close-session-store (store)
+  (when (session-store-descriptor store)
+    (cffi:foreign-funcall "close" :int (session-store-descriptor store) :int)
+    (setf (session-store-descriptor store) nil))
+  store)
+
+(defun %require-open-store (store)
+  (unless (session-store-descriptor store) (error "Session store is closed.")))
+
+(defun %sync-path (path)
+  (let ((fd (cffi:foreign-funcall "open" :string (namestring path) :int #o2000000 :int)))
+    (when (minusp fd) (error "Cannot open session path for synchronization: ~A" path))
+    (unwind-protect
+         (unless (zerop (cffi:foreign-funcall "fsync" :int fd :int))
+           (error "Cannot synchronize session path: ~A" path))
+      (cffi:foreign-funcall "close" :int fd :int))))
+
+(defun write-session-store (store data)
+  "Write validated plain data privately and atomically; never LOAD/EVAL state."
+  (%require-open-store store)
+  (check-data data)
+  (let* ((path (session-store-path store)) (directory (uiop:pathname-directory-pathname path))
+         ;; PRINT-READABLY may emit implementation-specific #A forms for
+         ;; base strings. We preserve text, not string storage specialization.
+         (text (let ((*print-readably* nil) (*print-escape* t) (*print-pretty* nil) (*print-circle* nil)
+                     (*print-base* 10) (*print-radix* nil) (*print-case* :upcase)
+                     (*read-default-float-format* 'single-float)
+                     (*print-level* nil) (*print-length* nil) (*package* (find-package :cl-user)))
+                 (write-to-string data))))
+    (when (> (length text) (* 4 1024 1024)) (error "Session snapshot exceeds 4 MiB text limit."))
+    (when (>= (length (babel:string-to-octets text :encoding :utf-8)) (* 8 1024 1024))
+      (error "Session snapshot exceeds 8 MiB encoded limit."))
+    (%check-reader-depth text)
+    (uiop:with-temporary-file (:stream stream :pathname temporary :directory directory
+                              :prefix ".lime-session-" :external-format :utf-8)
+      (%private-file temporary)
+      (write-line text stream)
+      :close-stream
+      (%sync-path temporary)
+      (unless (zerop (cffi:foreign-funcall "rename" :string (namestring temporary)
+                                         :string (namestring path) :int))
+        (error "Cannot atomically replace session file: ~A" path))
+      (%sync-path directory)))
+  data)
+
+(defun %check-reader-depth (text)
+  ;; Bound nesting before invoking the Lisp reader, including malformed input.
+  ;; No reader dispatch, comments, or quote syntax are needed in this format.
+  (let ((depth 0) (string-p nil) (escaped nil))
+    (loop for c across text do
+      (cond (escaped (setf escaped nil))
+            ((and string-p (char= c #\\)) (setf escaped t))
+            ((char= c #\") (setf string-p (not string-p)))
+            (string-p nil)
+            ((find c "#;'`,|\\") (error "Reader syntax is not allowed in session data."))
+            ((char= c #\() (when (> (incf depth) 128) (error "Session nesting is too deep.")))
+            ((char= c #\)) (when (minusp (decf depth)) (error "Unbalanced session data.")))))
+    (when (or string-p escaped (not (zerop depth))) (error "Truncated session data."))))
+
+(defun read-session-store (store)
+  "Read one bounded data form. Missing is NIL; malformed/unsupported input signals."
+  (%require-open-store store)
+  (let ((path (session-store-path store)))
+    (when (probe-file path)
+      (with-open-file (stream path :element-type '(unsigned-byte 8))
+        (when (> (file-length stream) (* 8 1024 1024)) (error "Session file exceeds 8 MiB.")))
+      (let ((text (uiop:read-file-string path :external-format :utf-8)))
+        (%check-reader-depth text)
+        (let ((*read-eval* nil) (*read-base* 10) (*read-default-float-format* 'single-float)
+              (*readtable* (copy-readtable nil))
+              (*package* (find-package :cl-user)))
+          (with-input-from-string (stream text)
+            (let* ((eof (gensym)) (data (read stream nil eof)))
+              (when (eq data eof) (error "Session file is empty."))
+              (unless (eq eof (read stream nil eof)) (error "Session file contains trailing data."))
+              (check-data data))))))))

src/presentation-navigation.lisp

@@ -0,0 +1,77 @@
+(in-package #:lime.core)
+
+;;;; Moving a live arrangement is distinct from recalling a saved checkpoint.
+;;;; This layer has no navigation preferences, renderer, or physical geometry.
+
+(defun activity-presentations (world activity-id)
+  (find-activity world activity-id)
+  (sort (loop for p being the hash-values of (world-presentations world)
+              when (equal activity-id (presentation-activity-id p)) collect p)
+        #'string< :key (lambda (p) (princ-to-string (presentation-id p)))))
+
+(defun preflight-presentation-bring (world head-id presentation-id)
+  "Inspect moving/resuming an arrangement, ignoring its own existing leases.
+Missing slots from partial checkpoint recalls are not requests to steal windows."
+  (let* ((p (find-presentation world presentation-id)) (copy (copy-presentation p)))
+    (dolist (id (presentation-unavailable-client-ids p)) (%remove-client-from-container copy id))
+    (let ((report (%preflight-activation world head-id (presentation-activity-id p)
+                                        (presentation-source-view-id p) presentation-id
+                                        (presentation-placements copy) (presentation-layout-root copy)
+                                        (presentation-layout-mode p) (presentation-layout-options p)
+                                        (presentation-focus-client-id copy))))
+      (setf (activation-report-conflicts report)
+            (remove-if (lambda (conflict)
+                         (equal presentation-id (activation-conflict-holder-presentation-id conflict)))
+                       (activation-report-conflicts report)))
+      report)))
+
+(defun bring-presentation-to-head (world presentation-id head-id &key expected-revision)
+  "Bring the current arrangement HERE; swap if it is already displayed elsewhere.
+
+An active swap preserves Presentation identities and lease objects. Inactive
+arrangements of the displaced Activity transpose between the same two Heads,
+so swapping a portion of an extended Activity cannot overwrite its other part.
+An inactive incoming arrangement simply resumes here; no other Head changes.
+No checkpoint is recalled, no hidden client is shown, and no View is modified."
+  (when (and expected-revision (/= expected-revision (world-revision world)))
+    (error 'stale-transition-plan))
+  (let* ((p (find-presentation world presentation-id))
+         (target (find-head world head-id))
+         (outgoing (current-presentation world head-id))
+         (from (presentation-head-id p))
+         (active-p (presentation-active-p world p)))
+    (when (eq p outgoing) (return-from bring-presentation-to-head p))
+    (validate-world world)
+    (let ((report (preflight-presentation-bring world head-id presentation-id)))
+      (unless (activation-report-ready-p report) (error 'activation-blocked :report report))
+      (let* ((activities (remove-duplicates
+                          (cons (presentation-activity-id p)
+                                (when (and active-p outgoing) (list (presentation-activity-id outgoing))))
+                          :test #'equal))
+             (moves (loop for other being the hash-values of (world-presentations world)
+                          when (member (presentation-activity-id other) activities :test #'equal)
+                            append
+                            (cond
+                              ((eq other p) (list (cons other head-id)))
+                              ((equal head-id (presentation-head-id other)) (list (cons other from)))
+                              ((and from (equal from (presentation-head-id other))) (list (cons other head-id)))))))
+        ;; Everything that can reject the transition has been checked above.
+        (if active-p
+            (setf (head-active-presentation-id (find-head world from))
+                  (and outgoing (presentation-id outgoing)))
+            (when outgoing (%release-presentation-leases world outgoing)))
+        (dolist (move moves) (setf (presentation-head-id (car move)) (cdr move)))
+        (setf (head-active-presentation-id target) presentation-id)
+        (unless active-p
+          ;; Same return semantics as a Head-local resume: stale missing slots
+          ;; disappear from the working arrangement, never from the checkpoint.
+          (setf (presentation-placements p) (%copy-placements (activation-report-desired-placements report))
+                (presentation-layout-root p) (%copy-layout-root (activation-report-desired-layout-root report))
+                (presentation-unavailable-client-ids p) nil
+                (presentation-focus-client-id p)
+                (%focus-from-grants (presentation-focus-client-id p) (presentation-client-ids p)))
+          (%claim-live-locations world p (presentation-client-ids p))
+          (dolist (id (presentation-client-ids p))
+            (setf (gethash id (world-leases world)) (make-lease :client-id id :presentation-id presentation-id))))
+        (%touch world)
+        p))))

src/topology.lisp

@@ -0,0 +1,211 @@
+(in-package #:lime.core)
+
+;;;; Explicit Head-topology reconciliation
+;;;
+;;; Physical output discovery belongs to an adapter, but deciding what becomes
+;;; of a live task when a Head disappears is model policy.  This module keeps
+;;; that decision inspectable and explicit: an outgoing Presentation either
+;;; moves intact to one chosen destination or becomes an unbound cached draft.
+
+(defun %world-head-ids (world)
+  (let (head-ids)
+    (maphash (lambda (head-id head)
+               (declare (ignore head))
+               (push head-id head-ids))
+             (world-heads world))
+    head-ids))
+
+(defun %require-distinct-head-ids (head-ids description)
+  (unless (and (listp head-ids) head-ids
+               (every #'identity head-ids)
+               (= (length head-ids)
+                  (length (remove-duplicates head-ids :test #'equal))))
+    (error 'invalid-transition :description description))
+  head-ids)
+
+(defun %topology-active-source (world head-id)
+  (let ((presentation (current-presentation world head-id)))
+    (when presentation
+      (make-head-topology-source
+       :head-id head-id
+       :presentation-id (presentation-id presentation)
+       :activity-id (presentation-activity-id presentation)
+       :source-view-id (presentation-source-view-id presentation)))))
+
+(defun preflight-head-topology-reconciliation (world desired-head-ids)
+  "Compare WORLD's logical Heads with DESIRED-HEAD-IDS without mutating state.
+
+Adapters supply only durable logical identifiers here, never pixels or X11
+objects. Every removed Head that currently has a Presentation appears in
+REMOVED-ACTIVE-SOURCES; a frontend or command caller can move it explicitly or
+leave it unmentioned to suspend its draft and release its window leases."
+  (%require-distinct-head-ids
+   desired-head-ids
+   "A Head topology needs at least one distinct, non-NIL Head id.")
+  (let* ((current-head-ids (%world-head-ids world))
+         (retained-head-ids
+           (remove-if-not (lambda (head-id)
+                            (member head-id desired-head-ids :test #'equal))
+                          current-head-ids))
+         (added-head-ids
+           (remove-if (lambda (head-id)
+                        (member head-id current-head-ids :test #'equal))
+                      desired-head-ids))
+         (removed-head-ids
+           (remove-if (lambda (head-id)
+                        (member head-id desired-head-ids :test #'equal))
+                      current-head-ids)))
+    (make-head-topology-report
+     :world-revision (world-revision world)
+     :current-head-ids (copy-list current-head-ids)
+     :desired-head-ids (copy-list desired-head-ids)
+     :added-head-ids added-head-ids
+     :retained-head-ids retained-head-ids
+     :removed-head-ids removed-head-ids
+     :removed-active-sources
+     (remove nil (mapcar (lambda (head-id)
+                           (%topology-active-source world head-id))
+                         removed-head-ids)))))
+
+(defun %require-head-topology-moves (report moves)
+  (unless (every (lambda (move) (typep move 'head-topology-move)) moves)
+    (error 'invalid-transition
+           :description "Topology moves must be HEAD-TOPOLOGY-MOVE structures."))
+  (let ((source-head-ids (mapcar #'head-topology-move-from-head-id moves))
+        (destination-head-ids (mapcar #'head-topology-move-to-head-id moves))
+        (removable-head-ids
+          (mapcar #'head-topology-source-head-id
+                  (head-topology-report-removed-active-sources report))))
+    (unless (= (length source-head-ids)
+               (length (remove-duplicates source-head-ids :test #'equal)))
+      (error 'invalid-transition
+             :description "A removed Head's Presentation can move only once."))
+    (unless (= (length destination-head-ids)
+               (length (remove-duplicates destination-head-ids :test #'equal)))
+      (error 'invalid-transition
+             :description "Only one Presentation can be active on a destination Head."))
+    (dolist (move moves)
+      (unless (member (head-topology-move-from-head-id move)
+                      removable-head-ids :test #'equal)
+        (error 'invalid-transition
+               :description "A topology move must originate from a removed Head with an active Presentation."))
+      (unless (member (head-topology-move-to-head-id move)
+                      (head-topology-report-desired-head-ids report) :test #'equal)
+        (error 'invalid-transition
+               :description "A topology move needs a destination in the desired Head set."))))
+  moves)
+
+(defun build-head-topology-reconciliation-plan (report &key moves)
+  "Build an explicit topology plan from a read-only REPORT.
+
+Each HEAD-TOPOLOGY-MOVE names a removed source Head and a desired destination
+Head. Omitted removed sources are deliberately suspended rather than guessed:
+their drafts survive unbound, their leases are released, and they can later be
+resumed onto an explicitly chosen Head. Added Heads without an incoming move
+remain blank."
+  (unless (typep report 'head-topology-report)
+    (error 'invalid-transition
+           :description "Topology reconciliation needs a HEAD-TOPOLOGY-REPORT."))
+  (%require-head-topology-moves report moves)
+  (make-head-topology-plan
+   :base-revision (head-topology-report-world-revision report)
+   :current-head-ids (copy-list (head-topology-report-current-head-ids report))
+   :desired-head-ids (copy-list (head-topology-report-desired-head-ids report))
+   :added-head-ids (copy-list (head-topology-report-added-head-ids report))
+   :removed-head-ids (copy-list (head-topology-report-removed-head-ids report))
+   :moves (mapcar (lambda (move)
+                    (make-head-topology-move
+                     :from-head-id (head-topology-move-from-head-id move)
+                     :to-head-id (head-topology-move-to-head-id move)))
+                  moves)))
+
+(defun %assert-head-topology-plan-current (world plan)
+  (unless (= (head-topology-plan-base-revision plan) (world-revision world))
+    (error 'stale-transition-plan))
+  (unless (%same-id-set-p (%world-head-ids world)
+                          (head-topology-plan-current-head-ids plan))
+    (error 'stale-transition-plan)))
+
+(defun %release-and-suspend-presentation (world head)
+  (let ((presentation-id (head-active-presentation-id head)))
+    (when presentation-id
+      (let ((presentation (find-presentation world presentation-id)))
+        (%release-presentation-leases world presentation)
+        (setf (head-active-presentation-id head) nil
+              (presentation-head-id presentation) nil)
+        presentation))))
+
+(defun %release-destination-presentation (world head)
+  (let ((presentation-id (head-active-presentation-id head)))
+    (when presentation-id
+      (let ((presentation (find-presentation world presentation-id)))
+        (%release-presentation-leases world presentation)
+        (setf (head-active-presentation-id head) nil)
+        presentation))))
+
+(defun commit-head-topology-reconciliation-plan (world plan)
+  "Commit PLAN atomically at the pure-model boundary.
+
+Incoming Presentations retain their exact draft, focus, and leases. An active
+destination Presentation is merely cached on its surviving Head after its
+leases are released. Unmoved removed Heads become unbound cached drafts, so
+no window stays invisibly leased to an unplugged monitor."
+  (unless (typep plan 'head-topology-plan)
+    (error 'invalid-transition
+           :description "Topology reconciliation needs a HEAD-TOPOLOGY-PLAN."))
+  (%assert-head-topology-plan-current world plan)
+  (let* ((moves (head-topology-plan-moves plan))
+         (move-source-ids (mapcar #'head-topology-move-from-head-id moves))
+         (move-sources
+           (mapcar (lambda (move)
+                     (let* ((source-head
+                              (find-head world
+                                         (head-topology-move-from-head-id move)))
+                            (presentation-id
+                              (head-active-presentation-id source-head)))
+                       (unless presentation-id
+                         (error 'stale-transition-plan))
+                       (cons move (find-presentation world presentation-id))))
+                   moves))
+         (suspended-presentation-ids '())
+         (moved-presentation-ids '()))
+    ;; Add logical Heads before routing an incoming Presentation to one.
+    (dolist (head-id (head-topology-plan-added-head-ids plan))
+      (setf (gethash head-id (world-heads world)) (make-head :id head-id)))
+    ;; A retained destination gives up only its own active leases. Its cached
+    ;; draft remains attached to that physical Head and can be resumed later.
+    (dolist (move moves)
+      (%release-destination-presentation
+       world (find-head world (head-topology-move-to-head-id move))))
+    ;; Removed sources either transfer whole or become unbound, lease-free
+    ;; drafts. The former release no leases: ownership follows the same
+    ;; Presentation object to its chosen destination.
+    (dolist (head-id (head-topology-plan-removed-head-ids plan))
+      (let ((head (find-head world head-id)))
+        (if (member head-id move-source-ids :test #'equal)
+            (setf (head-active-presentation-id head) nil)
+            (let ((suspended (%release-and-suspend-presentation world head)))
+              (when suspended
+                (push (presentation-id suspended) suspended-presentation-ids))))))
+    (dolist (entry move-sources)
+      (let* ((move (car entry))
+             (presentation (cdr entry))
+             (destination-head
+               (find-head world (head-topology-move-to-head-id move))))
+        (let ((displaced (activity-draft-for-head world (presentation-activity-id presentation)
+                                                (head-topology-move-to-head-id move))))
+          (when (and displaced (not (eq displaced presentation)))
+            (setf (presentation-head-id displaced) nil)))
+        (setf (presentation-head-id presentation)
+              (head-topology-move-to-head-id move)
+              (head-active-presentation-id destination-head)
+              (presentation-id presentation))
+        (push (presentation-id presentation) moved-presentation-ids)))
+    (dolist (head-id (head-topology-plan-removed-head-ids plan))
+      (remhash head-id (world-heads world)))
+    (%touch world)
+    (make-head-topology-result
+     :moved-presentation-ids (nreverse moved-presentation-ids)
+     :suspended-presentation-ids (nreverse suspended-presentation-ids)
+     :added-head-ids (copy-list (head-topology-plan-added-head-ids plan))
+     :removed-head-ids (copy-list (head-topology-plan-removed-head-ids plan)))))

src/ui/package.lisp

@@ -0,0 +1,48 @@
+(defpackage #:lime.ui
+  (:use #:cl)
+  (:documentation
+   "Renderer-neutral command-palette state for Lime frontends.")
+  (:export
+   #:ui-candidate
+   #:make-ui-candidate
+   #:ui-candidate-id
+   #:ui-candidate-label
+   #:ui-candidate-detail
+   #:ui-candidate-key-hint
+   #:ui-candidate-action
+   #:ui-key-node
+   #:make-ui-key-node
+   #:ui-key-node-id
+   #:ui-key-node-key
+   #:ui-key-node-label
+   #:ui-key-node-detail
+   #:ui-key-node-action
+   #:ui-key-node-children
+   #:ui-result
+   #:make-ui-result
+   #:ui-result-kind
+   #:ui-result-candidates
+   #:ui-result-message
+   #:ui-result-prompt
+   #:ui-result-initial-value
+   #:ui-result-submit-action
+   #:ui-close-result
+   #:ui-replace-result
+   #:ui-keep-open-result
+   #:ui-prompt-result
+   #:ui-session
+   #:make-ui-session
+   #:ui-session-mode
+   #:ui-session-query
+   #:ui-session-candidates
+   #:ui-session-key-root
+   #:ui-session-key-nodes
+   #:ui-session-key-path
+   #:ui-session-key-page
+   #:ui-session-selected-index
+   #:ui-session-status
+   #:ui-session-prompt
+   #:ui-session-selected-candidate
+   #:ui-session-apply-result
+   #:ui-session-activate-candidate
+   #:ui-session-handle-key))

src/ui/session.lisp

@@ -0,0 +1,365 @@
+(in-package #:lime.ui)
+
+;;;; Renderer-neutral palette session
+;;;
+;;; This is intentionally not an X11 widget. A frontend supplies candidate
+;;; actions, turns the current session into pixels, and forwards normalized
+;;; keys here. The same model can later power a bar popup, an IPC picker, or a
+;;; graphical Viewset selector without teaching the Lime core about UI state.
+
+(defstruct ui-candidate
+  "One searchable palette choice supplied by a frontend catalog.
+
+ACTION is a zero-argument function that returns a UI-RESULT. It may close over
+an adapter command surface, but this data type itself has no X11 dependency."
+  id
+  label
+  detail
+  key-hint
+  action)
+
+(defstruct ui-key-node
+  "One key-labelled entry in a renderer-neutral command tree.
+
+KEY is a character recognized while its parent menu is visible. A node may
+have CHILDREN to enter another menu, or an ACTION that returns a UI-RESULT.
+The node itself contains no X11, model, or command-layer policy."
+  id
+  key
+  label
+  detail
+  action
+  (children '()))
+
+(defstruct ui-result
+  "A frontend action's requested palette transition.
+
+KIND is :CLOSE, :REPLACE, :KEEP-OPEN, or :PROMPT. REPLACE supplies the next
+candidate set, which is how a View activation can turn into an explicit
+collision-choice menu without special-casing that workflow in the palette
+engine. PROMPT supplies a label and a string-submit action for the same
+renderer-neutral minibuffer interaction."
+  kind
+  candidates
+  message
+  prompt
+  initial-value
+  submit-action)
+
+(defun ui-close-result (&optional message)
+  (make-ui-result :kind :close :message message))
+
+(defun ui-replace-result (candidates &optional message)
+  (make-ui-result :kind :replace :candidates candidates :message message))
+
+(defun ui-keep-open-result (&optional message)
+  (make-ui-result :kind :keep-open :message message))
+
+(defun ui-prompt-result (prompt submit-action &key initial-value message)
+  "Ask the frontend to collect one non-empty string before SUBMIT-ACTION runs.
+
+PROMPT is display text and SUBMIT-ACTION receives the entered string. It must
+return another UI-RESULT, allowing a prompt to close, replace itself with a
+choice list, or request another prompt without the renderer learning any
+workflow semantics."
+  (make-ui-result :kind :prompt
+                  :prompt prompt
+                  :initial-value initial-value
+                  :submit-action submit-action
+                  :message message))
+
+(defstruct (ui-session (:constructor %make-ui-session))
+  root-candidates
+  all-candidates
+  (mode :search)
+  (query "")
+  (candidates '())
+  (selected-index 0)
+  prompt
+  submit-action
+  (key-root '())
+  (key-nodes '())
+  (key-path '())
+  (key-page 0)
+  (status "Type to filter; Enter to run; Esc to cancel."))
+
+(defun %searchable-text (candidate)
+  (format nil "~A ~A ~A"
+          (or (ui-candidate-label candidate) "")
+          (or (ui-candidate-detail candidate) "")
+          (or (ui-candidate-key-hint candidate) "")))
+
+(defun %fuzzy-match-score (query text)
+  "Return a lower-is-better fuzzy score for QUERY in TEXT, or NIL.
+
+An ordinary contiguous substring is preferred.  Otherwise every query
+character must appear in order, which makes compact dmenu-style input such as
+\"wmprj\" useful without turning search into a hard-to-predict scorer."
+  (let* ((needle (string-downcase query))
+         (haystack (string-downcase text))
+         (substring-position (search needle haystack)))
+    (cond
+      ((zerop (length needle)) 0)
+      (substring-position substring-position)
+      (t
+       (let ((next-position 0)
+             (first-position nil)
+             (gaps 0))
+         (loop for character across needle
+               for found-position = (position character haystack
+                                              :start next-position)
+               do (unless found-position
+                    (return-from %fuzzy-match-score nil))
+                  (unless first-position
+                    (setf first-position found-position))
+                  (incf gaps (- found-position next-position))
+                  (setf next-position (1+ found-position)))
+         ;; Keep a contiguous early match ahead of sparse matches, while
+         ;; retaining a deterministic order for ties in %REFRESH-CANDIDATES.
+         (+ 100 (* 10 gaps) (or first-position 0)))))))
+
+(defun %candidate-match-score (candidate query)
+  (%fuzzy-match-score query (%searchable-text candidate)))
+
+(defun %refresh-candidates (session)
+  (let ((query (ui-session-query session)))
+    (setf (ui-session-candidates session)
+          (if (zerop (length query))
+              (copy-list (ui-session-all-candidates session))
+              (mapcar #'second
+                      (stable-sort
+                       (loop for candidate in (ui-session-all-candidates session)
+                             for score = (%candidate-match-score candidate query)
+                             when score collect (list score candidate))
+                       #'< :key #'first)))
+          (ui-session-selected-index session) 0))
+  session)
+
+(defun make-ui-session (candidates &key status key-path (mode :search))
+  "Start a :SEARCH picker or :KEY-PATH command map, without running any action.
+
+The root catalog survives temporary pickers (Views, collisions, etc.), so
+returning to the command map and then searching means all commands again."
+  (let ((session (%refresh-candidates
+                  (%make-ui-session :root-candidates (copy-list candidates)
+                                    :all-candidates (copy-list candidates)
+                                    :key-root (copy-list key-path)))))
+    (ecase mode
+      (:search nil)
+      (:key-path (%switch-to-key-path session)))
+    (when status (setf (ui-session-status session) status))
+    session))
+
+(defun ui-session-selected-candidate (session)
+  (nth (ui-session-selected-index session) (ui-session-candidates session)))
+
+(defun %move-selection (session delta)
+  (let ((count (length (ui-session-candidates session))))
+    (when (plusp count)
+      (setf (ui-session-selected-index session)
+            (mod (+ (ui-session-selected-index session) delta) count))))
+  session)
+
+(defun %apply-result (session result)
+  (unless (typep result 'ui-result)
+    (error "A palette candidate action must return a UI-RESULT, got ~S." result))
+  (when (ui-result-message result)
+    (setf (ui-session-status session) (ui-result-message result)))
+  (ecase (ui-result-kind result)
+    ((:close :keep-open) nil)
+    (:replace
+     (setf (ui-session-mode session) :search
+           (ui-session-prompt session) nil
+           (ui-session-submit-action session) nil
+           (ui-session-all-candidates session) (copy-list (ui-result-candidates result))
+           (ui-session-status session)
+           (or (ui-result-message result) "Type to filter; Enter to choose; Esc to cancel.")
+           (ui-session-query session) "")
+     (%refresh-candidates session))
+    (:prompt
+     (unless (and (stringp (ui-result-prompt result))
+                  (functionp (ui-result-submit-action result)))
+       (error "A UI prompt result needs a string label and a submit function."))
+     (setf (ui-session-mode session) :prompt
+           (ui-session-prompt session) (ui-result-prompt result)
+           (ui-session-submit-action session) (ui-result-submit-action result)
+           (ui-session-status session)
+           (or (ui-result-message result) "Enter to confirm; Esc to cancel.")
+           (ui-session-query session) (or (ui-result-initial-value result) "")
+           (ui-session-candidates session) '()
+           (ui-session-selected-index session) 0)))
+  result)
+
+(defun ui-session-apply-result (session result)
+  "Apply a declarative UI RESULT to SESSION and return RESULT.
+
+Frontends normally receive a result from UI-SESSION-HANDLE-KEY.  This public
+entry point also lets a frontend begin directly in a prompt or a replacement
+choice list without pretending the user pressed an initial key."
+  (%apply-result session result))
+
+(defun %switch-to-search (session)
+  (setf (ui-session-mode session) :search
+        (ui-session-all-candidates session) (copy-list (ui-session-root-candidates session))
+        (ui-session-prompt session) nil
+        (ui-session-submit-action session) nil
+        (ui-session-key-nodes session) '()
+        (ui-session-key-path session) '()
+        (ui-session-key-page session) 0
+        (ui-session-query session) ""
+        (ui-session-status session) "Type to filter; Enter to run; Tab for menu; Esc to cancel.")
+  (%refresh-candidates session)
+  (ui-keep-open-result))
+
+(defun %key-path-description (session)
+  (if (null (ui-session-key-path session))
+      "root"
+      (format nil "~{~A~^ > ~}"
+              (mapcar #'ui-key-node-label (ui-session-key-path session)))))
+
+(defun %switch-to-key-path (session)
+  (if (null (ui-session-key-root session))
+      (%apply-result session
+                     (ui-keep-open-result "No key-path commands are configured."))
+      (progn
+        (setf (ui-session-mode session) :key-path
+              (ui-session-prompt session) nil
+              (ui-session-submit-action session) nil
+              (ui-session-key-nodes session) (ui-session-key-root session)
+              (ui-session-key-path session) '()
+              (ui-session-key-page session) 0
+              (ui-session-query session) ""
+              (ui-session-candidates session) '()
+              (ui-session-selected-index session) 0
+              (ui-session-status session)
+              "Tab search; Backspace up; Esc close.")
+        (ui-keep-open-result))))
+
+(defun %key-node-for-key (session key)
+  (find key (ui-session-key-nodes session)
+        :key #'ui-key-node-key :test #'char-equal))
+
+(defun %enter-key-node (session node)
+  (cond
+    ((ui-key-node-children node)
+     (setf (ui-session-key-path session)
+           (append (ui-session-key-path session) (list node))
+           (ui-session-key-nodes session) (ui-key-node-children node)
+           (ui-session-key-page session) 0
+           (ui-session-status session)
+           "Tab search; Backspace up; Esc close.")
+     (ui-keep-open-result))
+    ((ui-key-node-action node)
+     (%apply-result session (funcall (ui-key-node-action node))))
+    (t
+     (%apply-result session
+                    (ui-keep-open-result "That key has no action yet.")))))
+
+(defun %handle-key-path-character (session key)
+  (let ((node (%key-node-for-key session key)))
+    (cond
+      (node (%enter-key-node session node))
+      ((char= key #\Space) (%switch-to-search session))
+      (t (%apply-result
+          session
+          (ui-keep-open-result
+           (format nil "~C is not available in ~A."
+                   key (%key-path-description session))))))))
+
+(defun %key-path-up (session)
+  (let ((path (ui-session-key-path session)))
+    (when path
+      (let ((parent-path (butlast path)))
+        (setf (ui-session-key-path session) parent-path
+              (ui-session-key-page session) 0
+              (ui-session-key-nodes session)
+              (if parent-path
+                  (ui-key-node-children (car (last parent-path)))
+                  (ui-session-key-root session)))
+        (setf (ui-session-status session)
+              "Tab search; Backspace up; Esc close.")))
+    (ui-keep-open-result)))
+
+(defun %blank-string-p (string)
+  (zerop (length (string-trim '(#\Space #\Tab #\Newline #\Return) string))))
+
+(defun %handle-prompt-return (session)
+  (let ((input (ui-session-query session)))
+    (if (%blank-string-p input)
+        (%apply-result session (ui-keep-open-result "Input is required."))
+        (%apply-result session
+                       (funcall (ui-session-submit-action session) input)))))
+
+(defun ui-session-activate-candidate (session candidate)
+  "Activate a displayed CANDIDATE with the same transition as keyboard Return.
+
+Use the actual candidate object, not an index into an old filtered list. A
+stale hit from a previous picker or query must never run a different command."
+  (let ((index (and (eq (ui-session-mode session) :search)
+                    (position candidate (ui-session-candidates session) :test #'eq))))
+    (if index
+        (progn
+          (setf (ui-session-selected-index session) index)
+          (%apply-result session (funcall (ui-candidate-action candidate))))
+        (ui-keep-open-result))))
+
+(defun ui-session-handle-key (session key)
+  "Update SESSION for normalized KEY and return its requested UI-RESULT.
+
+KEY is a character or :UP, :DOWN, :RETURN, :BACKSPACE, :TAB, :ESCAPE,
+:PAGE-UP, or :PAGE-DOWN. In search mode characters filter locally and candidate
+actions run on :RETURN. In prompt mode they edit the entered string and
+:RETURN invokes the prompt submit action. In key-path mode characters select
+the visible command tree. Every action returns a declarative result for the
+frontend to realize."
+  (case key
+    (:escape (ui-close-result))
+    ((:page-up :page-down)
+     (when (eq (ui-session-mode session) :key-path)
+       ;; The renderer clamps this viewport request to its measured page count.
+       (setf (ui-session-key-page session)
+             (max 0 (+ (ui-session-key-page session) (if (eq key :page-up) -1 1)))))
+     (ui-keep-open-result))
+    (:tab
+     (ecase (ui-session-mode session)
+       (:search (%switch-to-key-path session))
+       (:key-path (%switch-to-search session))
+       (:prompt (%apply-result session
+                               (ui-keep-open-result "Finish or cancel this prompt first.")))))
+    (:up (progn (when (eq (ui-session-mode session) :search)
+                  (%move-selection session -1))
+                (ui-keep-open-result)))
+    (:down (progn (when (eq (ui-session-mode session) :search)
+                    (%move-selection session 1))
+                  (ui-keep-open-result)))
+    (:backspace
+     (if (eq (ui-session-mode session) :key-path)
+         (%key-path-up session)
+         (let ((query (ui-session-query session)))
+           (when (plusp (length query))
+             (setf (ui-session-query session) (subseq query 0 (1- (length query))))
+             (when (eq (ui-session-mode session) :search)
+               (%refresh-candidates session)))
+           (ui-keep-open-result))))
+    (:return
+     (ecase (ui-session-mode session)
+       (:prompt (%handle-prompt-return session))
+       (:key-path (%apply-result session
+                                 (ui-keep-open-result "Choose one of the shown keys.")))
+       (:search
+        (let ((candidate (ui-session-selected-candidate session)))
+          (if candidate
+              (ui-session-activate-candidate session candidate)
+              (%apply-result session
+                             (ui-keep-open-result "No matching command.")))))))
+    (otherwise
+     (when (and (characterp key) (graphic-char-p key))
+       (if (eq (ui-session-mode session) :key-path)
+           (return-from ui-session-handle-key
+             (%handle-key-path-character session key))
+           (progn
+             (setf (ui-session-query session)
+                   (concatenate 'string (ui-session-query session) (string key)))
+             (when (eq (ui-session-mode session) :search)
+               (%refresh-candidates session)))))
+     (ui-keep-open-result))))

src/viewset.lisp

@@ -0,0 +1,335 @@
+(in-package #:lime.core)
+
+;;;; Atomic multi-Head Viewset activation
+;;;
+;;; A View remains the useful one-Head checkpoint.  A Viewset is only a named
+;;; selection of several such checkpoints.  Its planner deliberately looks at
+;;; all selected Heads as one replacement group: that is what makes a genuine
+;;; left/right View swap safe without transient duplicate-View or duplicate-
+;;; Lease fiction.
+
+(defun viewset-report-ready-p (report)
+  "Return true when REPORT needs no policy choice or repair."
+  (null (viewset-report-conflicts report)))
+
+(defun %viewset-conflicts-of-kind (report kind)
+  (remove-if-not (lambda (conflict)
+                   (eq (viewset-conflict-kind conflict) kind))
+                 (viewset-report-conflicts report)))
+
+(defun %viewset-entry-head-ids (entries)
+  (mapcar #'viewset-entry-head-id entries))
+
+(defun %viewset-outgoing-presentation-ids (world entries)
+  (mapcar (lambda (entry)
+            (let ((head-id (viewset-entry-head-id entry)))
+              (cons head-id
+                    (head-active-presentation-id (find-head world head-id)))))
+          entries))
+
+(defun %viewset-outgoing-presentation-id-p (presentation-id outgoing-ids)
+  (member presentation-id (mapcar #'cdr outgoing-ids) :test #'equal))
+
+(defun %viewset-conflict (kind entry &key client-id view-id holder)
+  (make-viewset-conflict
+   :kind kind
+   :target-head-id (viewset-entry-head-id entry)
+   :client-id client-id
+   :view-id view-id
+   :holder-head-id (and holder (presentation-head-id holder))
+   :holder-presentation-id (and holder (presentation-id holder))))
+
+(defun preflight-viewset-activation (world viewset-id)
+  "Inspect VIEWSET-ID across every selected Head without changing WORLD.
+
+Each target Head's current Presentation is part of the same outgoing group.
+Its leases and mounted View are therefore harmless to another incoming entry
+in this Viewset: commit will release all of them before granting any incoming
+lease.  A lease or mounted View on an unselected Head remains a real conflict.
+Two Viewset entries requesting the same real client are deliberately reported
+as an unresolvable internal conflict rather than receiving arbitrary order.
+"
+  (let* ((viewset (find-viewset world viewset-id))
+         (entries (%copy-viewset-entries (viewset-entries viewset)))
+         ;; FIND-HEAD validates every saved logical Head before any caller can
+         ;; act on a partial report.
+         (outgoing-presentation-ids
+           (%viewset-outgoing-presentation-ids world entries))
+         (target-head-ids (%viewset-entry-head-ids entries))
+         (conflicts '())
+         (requested-client-heads (make-hash-table :test #'equal)))
+    (dolist (entry entries)
+      (let* ((view-id (viewset-entry-view-id entry))
+             (view (find-view world view-id)))
+        ;; A named View currently mounted on another selected Head is fine:
+        ;; that holder is itself being replaced by this same atomic commit.
+        (dolist (presentation (%active-presentations world))
+          (when (and (equal (presentation-source-view-id presentation) view-id)
+                     (not (member (presentation-head-id presentation)
+                                  target-head-ids :test #'equal)))
+            (push (%viewset-conflict :view-mounted entry
+                                     :view-id view-id :holder presentation)
+                  conflicts)))
+        (dolist (placement (view-placements view))
+          (let* ((client-id (placement-client-id placement))
+                 (first-target-head-id
+                   (gethash client-id requested-client-heads)))
+            (if first-target-head-id
+                ;; The first request is enough context to make the definition
+                ;; repairable; a second demand cannot be resolved by :PARTIAL
+                ;; or :TAKE without silently picking a winner.
+                (push (make-viewset-conflict
+                       :kind :client-requested
+                       :target-head-id (viewset-entry-head-id entry)
+                       :client-id client-id
+                       :holder-head-id first-target-head-id)
+                      conflicts)
+                (setf (gethash client-id requested-client-heads)
+                      (viewset-entry-head-id entry)))
+            (let ((lease (lease-for-client world client-id)))
+              (when (and lease
+                         (not (%viewset-outgoing-presentation-id-p
+                               (lease-presentation-id lease)
+                               outgoing-presentation-ids)))
+                (push (%viewset-conflict
+                       :client-leased entry :client-id client-id
+                       :holder (find-presentation world
+                                                  (lease-presentation-id lease)))
+                      conflicts)))))))
+    (make-viewset-report
+     :world-revision (world-revision world)
+     :viewset-id viewset-id
+     :entries entries
+     :outgoing-presentation-ids outgoing-presentation-ids
+     :conflicts (nreverse conflicts))))
+
+(defun %require-viewset-resolvable-conflicts (report)
+  "Reject conflicts that policy cannot responsibly resolve automatically."
+  (when (remove-if (lambda (conflict)
+                     (eq (viewset-conflict-kind conflict) :client-leased))
+                   (viewset-report-conflicts report))
+    (error 'activation-blocked :report report)))
+
+(defun %viewset-unavailable-by-head (report)
+  "Return deterministic partial-activation omissions in Viewset entry order."
+  (mapcar
+   (lambda (entry)
+     (cons (viewset-entry-head-id entry)
+           (loop for conflict in (viewset-report-conflicts report)
+                 when (and (eq (viewset-conflict-kind conflict) :client-leased)
+                           (equal (viewset-conflict-target-head-id conflict)
+                                  (viewset-entry-head-id entry)))
+                   collect (viewset-conflict-client-id conflict))))
+   (viewset-report-entries report)))
+
+(defun %make-viewset-plan (report policy unavailable-by-head take-client-ids)
+  (make-viewset-plan
+   :base-revision (viewset-report-world-revision report)
+   :viewset-id (viewset-report-viewset-id report)
+   :policy policy
+   :entries (%copy-viewset-entries (viewset-report-entries report))
+   :outgoing-presentation-ids (copy-tree
+                               (viewset-report-outgoing-presentation-ids report))
+   :unavailable-client-ids-by-head (copy-tree unavailable-by-head)
+   :take-client-ids (copy-list take-client-ids)))
+
+(defun build-strict-viewset-plan (report)
+  "Build a Viewset plan only when every requested client and View is free."
+  (unless (typep report 'viewset-report)
+    (error 'invalid-transition :description "Viewset planning needs a VIEWSET-REPORT."))
+  (unless (viewset-report-ready-p report)
+    (error 'activation-blocked :report report))
+  (%make-viewset-plan report :strict '() '()))
+
+(defun build-partial-viewset-plan (report)
+  "Build a Viewset plan that omits only clients leased outside its target group."
+  (unless (typep report 'viewset-report)
+    (error 'invalid-transition :description "Viewset planning needs a VIEWSET-REPORT."))
+  (%require-viewset-resolvable-conflicts report)
+  (%make-viewset-plan report :partial (%viewset-unavailable-by-head report) '()))
+
+(defun build-taking-viewset-plan (report)
+  "Build a Viewset plan that explicitly takes outside client leases together."
+  (unless (typep report 'viewset-report)
+    (error 'invalid-transition :description "Viewset planning needs a VIEWSET-REPORT."))
+  (%require-viewset-resolvable-conflicts report)
+  (%make-viewset-plan
+   report :take '()
+   (remove-duplicates
+    (mapcar #'viewset-conflict-client-id
+            (%viewset-conflicts-of-kind report :client-leased))
+    :test #'equal)))
+
+(defun %viewset-plan-unavailable-client-ids (plan head-id)
+  (copy-list (cdr (assoc head-id
+                         (viewset-plan-unavailable-client-ids-by-head plan)
+                         :test #'equal))))
+
+(defun %assert-viewset-plan-current (world plan)
+  (unless (= (viewset-plan-base-revision plan) (world-revision world))
+    (error 'stale-transition-plan))
+  (let ((viewset (find-viewset world (viewset-plan-viewset-id plan))))
+    ;; A normal CREATE-VIEWSET revision check catches mutation. This direct
+    ;; shape check also protects callers constructing a plan by hand.
+    (unless (equal (mapcar (lambda (entry)
+                             (list (viewset-entry-head-id entry)
+                                   (viewset-entry-view-id entry)))
+                           (viewset-entries viewset))
+                   (mapcar (lambda (entry)
+                             (list (viewset-entry-head-id entry)
+                                   (viewset-entry-view-id entry)))
+                           (viewset-plan-entries plan)))
+      (error 'stale-transition-plan)))
+  (dolist (entry (viewset-plan-entries plan))
+    (let* ((head-id (viewset-entry-head-id entry))
+           (head (find-head world head-id))
+           (expected (cdr (assoc head-id
+                                 (viewset-plan-outgoing-presentation-ids plan)
+                                 :test #'equal))))
+      (unless (equal (head-active-presentation-id head) expected)
+        (error 'stale-transition-plan)))))
+
+(defun %validate-viewset-plan (world plan)
+  (unless (member (viewset-plan-policy plan) '(:strict :partial :take))
+    (error 'invalid-transition
+           :description "A Viewset plan policy must be :STRICT, :PARTIAL, or :TAKE."))
+  (%validate-viewset-entries world (viewset-plan-entries plan))
+  ;; Reuse the read-only collision logic at commit time. A legitimate plan is
+  ;; fresh by revision, so this is primarily a defense against hand-built
+  ;; inconsistent plans at the public core boundary.
+  (let ((report (preflight-viewset-activation world (viewset-plan-viewset-id plan))))
+    (ecase (viewset-plan-policy plan)
+      (:strict
+       (unless (viewset-report-ready-p report)
+         (error 'activation-blocked :report report))
+       (unless (and (null (viewset-plan-unavailable-client-ids-by-head plan))
+                    (null (viewset-plan-take-client-ids plan)))
+         (error 'invalid-transition
+                :description "A strict Viewset plan may not omit or take clients.")))
+      (:partial
+       (%require-viewset-resolvable-conflicts report)
+       (unless (equal (viewset-plan-unavailable-client-ids-by-head plan)
+                      (%viewset-unavailable-by-head report))
+         (error 'invalid-transition
+                :description "A partial Viewset plan does not match its preflight omissions.")))
+      (:take
+       (%require-viewset-resolvable-conflicts report)
+       (let ((expected-takes
+               (remove-duplicates
+                (mapcar #'viewset-conflict-client-id
+                        (%viewset-conflicts-of-kind report :client-leased))
+                :test #'equal)))
+         (unless (and (equal (sort (copy-list (viewset-plan-take-client-ids plan))
+                                   #'string< :key #'princ-to-string)
+                             (sort (copy-list expected-takes)
+                                   #'string< :key #'princ-to-string))
+                      (null (viewset-plan-unavailable-client-ids-by-head plan)))
+           (error 'invalid-transition
+                  :description "A taking Viewset plan does not match its preflight leases."))))))
+  (dolist (entry (viewset-plan-entries plan))
+    (let* ((head-id (viewset-entry-head-id entry))
+           (view (find-view world (viewset-entry-view-id entry)))
+           (unavailable-client-ids
+             (%viewset-plan-unavailable-client-ids plan head-id)))
+      (dolist (client-id unavailable-client-ids)
+        (unless (%placement-for-client (view-placements view) client-id)
+          (error 'invalid-transition
+                 :description "A Viewset plan omits an unplaced client."))))))
+
+(defun %release-viewset-outgoing-presentations (world plan)
+  (dolist (entry (viewset-plan-entries plan))
+    (let* ((head-id (viewset-entry-head-id entry))
+           (head (find-head world head-id))
+           (presentation-id (head-active-presentation-id head)))
+      (when presentation-id
+        (%release-presentation-leases world (find-presentation world presentation-id))
+        (setf (head-active-presentation-id head) nil)))))
+
+(defun %install-viewset-entry (world entry unavailable-client-ids)
+  "Mount ENTRY as a fresh Presentation after all outgoing leases are released."
+  (let* ((head-id (viewset-entry-head-id entry))
+         (head (find-head world head-id))
+         (view (find-view world (viewset-entry-view-id entry)))
+         (grant-client-ids
+           (remove-if (lambda (client-id)
+                        (member client-id unavailable-client-ids :test #'equal))
+                      (%placement-client-ids (view-placements view))))
+         (presentation (or (activity-draft-for-head world (view-activity-id view) head-id)
+                           (make-presentation :id (%fresh-presentation-id world)))))
+    (setf (presentation-head-id presentation) head-id
+          (presentation-activity-id presentation) (view-activity-id view)
+          (presentation-source-view-id presentation) (view-id view)
+          (presentation-placements presentation) (%copy-placements (view-placements view))
+          (presentation-layout-root presentation) (%copy-layout-root (view-layout-root view))
+          (presentation-layout-mode presentation) (view-layout-mode view)
+          (presentation-layout-options presentation) (copy-tree (view-layout-options view))
+          (presentation-focus-client-id presentation)
+          (%focus-from-grants (view-focus-client-id view) grant-client-ids)
+          (presentation-dirty-p presentation) (not (null unavailable-client-ids))
+          (presentation-unavailable-client-ids presentation)
+          (copy-list unavailable-client-ids))
+    (setf (gethash (presentation-id presentation) (world-presentations world)) presentation
+          (head-active-presentation-id head) (presentation-id presentation))
+    (%claim-live-locations world presentation grant-client-ids)
+    (dolist (client-id grant-client-ids)
+      ;; Internal duplicate requests and foreign leases were ruled out before
+      ;; we started mutation. Keep this hard guard for model callers anyway.
+      (when (lease-for-client world client-id)
+        (error 'invalid-transition
+               :description "Viewset activation would give a client two leases."))
+      (setf (gethash client-id (world-leases world))
+            (make-lease :client-id client-id
+                        :presentation-id (presentation-id presentation))))
+    presentation))
+
+(defun commit-viewset-plan (world plan)
+  "Commit PLAN as one atomic whole-desk Viewset transition.
+
+All target Heads release their outgoing leases before any incoming View mounts.
+That ordering is the semantic point of Viewsets: legitimate swaps do not need
+temporary duplicate View exceptions, and a failed preflight has made no model
+or X11 change."
+  (unless (typep plan 'viewset-plan)
+    (error 'invalid-transition :description "Viewset activation needs a VIEWSET-PLAN."))
+  (%assert-viewset-plan-current world plan)
+  (%validate-viewset-plan world plan)
+  (%release-viewset-outgoing-presentations world plan)
+  ;; Only :TAKE has outside incumbent leases left at this point. It explicitly
+  ;; degrades those live drafts without touching their saved Views.
+  (when (eq (viewset-plan-policy plan) :take)
+    (dolist (client-id (viewset-plan-take-client-ids plan))
+      (%transfer-away-from-incumbent world client-id)))
+  (let ((presentation-ids '())
+        (unavailable-by-head '()))
+    (dolist (entry (viewset-plan-entries plan))
+      (let* ((head-id (viewset-entry-head-id entry))
+             (unavailable-client-ids
+               (%viewset-plan-unavailable-client-ids plan head-id))
+             (presentation
+               (%install-viewset-entry world entry unavailable-client-ids)))
+        (push (cons head-id (presentation-id presentation)) presentation-ids)
+        (when unavailable-client-ids
+          (push (cons head-id unavailable-client-ids) unavailable-by-head))))
+    (%touch world)
+    (make-viewset-result
+     :viewset-id (viewset-plan-viewset-id plan)
+     :presentation-ids (nreverse presentation-ids)
+     :unavailable-client-ids-by-head (nreverse unavailable-by-head))))
+
+(defun activate-viewset-strictly (world viewset-id)
+  "Activate VIEWSET-ID only when every selected Head can mount completely."
+  (commit-viewset-plan world
+                       (build-strict-viewset-plan
+                        (preflight-viewset-activation world viewset-id))))
+
+(defun activate-viewset-partially (world viewset-id)
+  "Activate VIEWSET-ID without taking clients leased outside its target Heads."
+  (commit-viewset-plan world
+                       (build-partial-viewset-plan
+                        (preflight-viewset-activation world viewset-id))))
+
+(defun activate-viewset-taking (world viewset-id)
+  "Activate VIEWSET-ID and explicitly transfer outside client leases."
+  (commit-viewset-plan world
+                       (build-taking-viewset-plan
+                        (preflight-viewset-activation world viewset-id))))

src/x11/activity-navigation-ui.lisp

@@ -0,0 +1,63 @@
+(in-package #:lime.x11)
+
+;;;; Explicit footprint commands use the ordinary dropdown, not a second UI.
+
+(defun %ui-activity-monitor-context (backend)
+  (let* ((head (x11-backend-focused-head-id backend))
+         (p (%current-presentation-or-error backend head)))
+    (list :head head :presentation (presentation-id p) :activity (presentation-activity-id p)
+          :revision (world-revision (x11-backend-world backend)))))
+
+(defun %ui-activity-monitor-context-valid-p (backend context)
+  (let ((p (current-presentation (x11-backend-world backend) (getf context :head))))
+    (and (equal (getf context :head) (x11-backend-focused-head-id backend)) p
+         (equal (getf context :presentation) (presentation-id p))
+         (= (getf context :revision) (world-revision (x11-backend-world backend))))))
+
+(defun %ui-extend-activity-result (backend)
+  (let* ((context (%ui-activity-monitor-context backend))
+         (activity (getf context :activity))
+         (heads (remove (getf context :head) (backend-head-ids backend) :test #'equal)))
+    (if (null heads) (ui-keep-open-result "There is no other monitor to extend onto.")
+        (ui-replace-result
+         (cons (make-ui-candidate :id :cancel :label "Cancel" :key-hint "Esc"
+                                  :action (lambda () (ui-close-result)))
+               (loop for head in heads collect
+                 (let ((target head))
+                   (make-ui-candidate
+                    :id (list :extend-activity activity target)
+                    :label (format nil "Extend ~A onto ~A" (activity-name (find-activity (x11-backend-world backend) activity)) target)
+                    :detail "open its portion there; leave this monitor and its windows in place"
+                    :key-hint "Enter"
+                    :action (lambda ()
+                              (if (not (%ui-activity-monitor-context-valid-p backend context))
+                                  (ui-keep-open-result "The desk changed. Cancel and choose the monitor again.")
+                                  (progn
+                                    (backend-extend-activity-to-head backend activity target
+                                                                    :expected-revision (getf context :revision))
+                                    (ui-close-result "Activity extended; move or show windows on its new portion."))))))))
+         "Choose a monitor. This explicitly enables independent portions; it does not duplicate or gather windows."))))
+
+(defun %ui-portable-activity-result (backend)
+  (let* ((context (%ui-activity-monitor-context backend))
+         (activity (getf context :activity)))
+    (ui-replace-result
+     (list (make-ui-candidate :id :cancel :label "Cancel" :key-hint "Esc" :action (lambda () (ui-close-result)))
+           (make-ui-candidate
+            :id (list :portable-activity activity) :label "Use this arrangement on one monitor" :key-hint "Enter"
+            :detail "other portions must be empty and inactive; hidden windows and saved Views are kept"
+            :action (lambda ()
+                      (if (not (%ui-activity-monitor-context-valid-p backend context))
+                          (ui-keep-open-result "The desk changed. Cancel and review the Activity again.")
+                          (progn
+                            (backend-make-activity-portable backend activity (getf context :head)
+                                                            :expected-revision (getf context :revision))
+                            (ui-close-result "Activity is portable; selecting it elsewhere brings it there."))))))
+     "Make this Activity portable? Empty portions lose their checkpoint labels, but no saved View or window is deleted.")))
+
+(defun %ui-activity-monitor-candidates (backend)
+  (when (current-presentation (x11-backend-world backend) (x11-backend-focused-head-id backend))
+    (list (make-ui-candidate :id :extend-activity :label "Extend Activity to another monitor..." :key-hint "Enter"
+                            :action (lambda () (%ui-extend-activity-result backend)))
+          (make-ui-candidate :id :portable-activity :label "Use Activity on one monitor..." :key-hint "Enter"
+                            :action (lambda () (%ui-portable-activity-result backend))))))

src/x11/activity-navigation.lisp

@@ -0,0 +1,149 @@
+(in-package #:lime.x11)
+
+;;;; Portable versus deliberately extended navigation is adapter policy, not
+;;;; another kind of Activity or View. The core only moves actual arrangements.
+;;;; A sidecar keeps this persistent policy independent of backend struct layout.
+
+(defstruct activity-navigation-state world (rows nil) (generation 0) observed-revision)
+(defvar *backend-activity-navigation-states* (make-hash-table :test #'eq #+sbcl :weakness #+sbcl :key))
+
+(defun %forget-activity-navigation-state (backend)
+  (remhash backend *backend-activity-navigation-states*))
+
+(defun %arrangement-substantive-p (p)
+  ;; An empty saved checkpoint is still intentional, unlike an old empty draft.
+  (or (presentation-placements p) (presentation-source-view-id p)))
+
+(defun %infer-activity-navigation-row (world activity-id)
+  "Conservative one-time migration. Never move/delete any existing arrangement."
+  (let* ((parts (activity-presentations world activity-id))
+         (substantive (remove-if-not #'%arrangement-substantive-p parts))
+         (active (remove-if-not (lambda (p) (presentation-active-p world p)) parts)))
+    (if (or (rest substantive) (and (null substantive) (rest active)))
+        (list activity-id :extended nil)
+        (list activity-id :portable
+              (let ((p (or (first substantive) (first active) (first parts))))
+                (and p (presentation-id p)))))))
+
+(defun %activity-navigation-state (backend)
+  (let* ((world (x11-backend-world backend))
+         (state (gethash backend *backend-activity-navigation-states*)))
+    (unless (and state (eq world (activity-navigation-state-world state)))
+      (setf state (make-activity-navigation-state :world world)
+            (gethash backend *backend-activity-navigation-states*) state))
+    (unless (eql (world-revision world) (activity-navigation-state-observed-revision state))
+      (let ((rows
+              (loop for a in (list-activities world) for id = (activity-id a)
+                    for existing = (assoc id (activity-navigation-state-rows state) :test #'equal)
+                    collect
+                    (cond
+                      ((null existing) (%infer-activity-navigation-row world id))
+                      ((eq :extended (second existing)) existing)
+                      (t
+                       (let* ((parts (activity-presentations world id))
+                              (primary (find (third existing) parts :key #'presentation-id :test #'equal))
+                              (others (remove primary parts)))
+                         (cond
+                           ((null primary) (%infer-activity-navigation-row world id))
+                           ;; Explicit checkpoint/window placement on another
+                           ;; Head may also extend the Activity. Never auto-fold
+                           ;; it again when clients close or become hidden.
+                           ((some (lambda (p) (and (%arrangement-substantive-p p)
+                                                   (or (%arrangement-substantive-p primary)
+                                                       (presentation-active-p world p)))) others)
+                            (list id :extended nil))
+                           (t existing))))))))
+        (unless (equal rows (activity-navigation-state-rows state))
+          (incf (activity-navigation-state-generation state))
+          (setf (activity-navigation-state-rows state) rows))
+        (setf (activity-navigation-state-observed-revision state) (world-revision world))))
+    state))
+
+(defun %activity-navigation-row (backend activity-id)
+  (find-activity (x11-backend-world backend) activity-id)
+  (assoc activity-id (activity-navigation-state-rows (%activity-navigation-state backend)) :test #'equal))
+
+(defun backend-activity-navigation-mode (backend activity-id)
+  "Return :PORTABLE or :EXTENDED. Window closure never resets an explicit span."
+  (second (%activity-navigation-row backend activity-id)))
+
+(defun %portable-activity-presentation (backend activity-id)
+  (let* ((row (%activity-navigation-row backend activity-id)) (id (third row)))
+    (when (and (eq :portable (second row)) id) (find-presentation (x11-backend-world backend) id))))
+
+(defun %set-activity-navigation (backend activity-id mode presentation-id)
+  (let ((state (%activity-navigation-state backend)))
+    (setf (activity-navigation-state-rows state)
+          (cons (list activity-id mode presentation-id)
+                (remove activity-id (activity-navigation-state-rows state) :key #'first :test #'equal)))
+    (incf (activity-navigation-state-generation state)))
+  mode)
+
+(defun %activity-navigation-snapshot (backend)
+  (lime.persistence:copy-data (activity-navigation-state-rows (%activity-navigation-state backend))))
+
+(defun %activity-navigation-read-data (data world)
+  (lime.persistence:check-data data)
+  (let ((seen nil))
+    (dolist (row data)
+      (unless (and (listp row) (= 3 (length row)) (member (second row) '(:portable :extended)))
+        (error "Invalid activity navigation row."))
+      (destructuring-bind (id mode primary) row
+        (find-activity world id)
+        (when (member id seen :test #'equal) (error "Duplicate activity navigation policy."))
+        (push id seen)
+        (when (and (eq mode :extended) primary) (error "Extended Activity cannot have one primary arrangement."))
+        (when primary
+          (unless (equal id (presentation-activity-id (find-presentation world primary)))
+            (error "Portable arrangement belongs to another Activity.")))))
+    (unless (= (length seen) (length (list-activities world)))
+      (error "Activity navigation policies must cover every Activity.")))
+  (make-activity-navigation-state :world world :rows (copy-tree data)))
+
+(defun %portable-view-preview-world (backend view-id head-id)
+  "Preview the portable move on a detached model before offering lease choices.
+No live rearrangement happens merely because the user opened a conflict menu."
+  (let* ((world (x11-backend-world backend)) (view (find-view world view-id))
+         (p (%portable-activity-presentation backend (view-activity-id view))))
+    (when (and p (not (eq p (current-presentation world head-id))))
+      (let ((copy (lime.persistence:restore-world (lime.persistence:snapshot-world world))))
+        (bring-presentation-to-head copy (presentation-id p) head-id)
+        copy))))
+
+(defun backend-extend-activity-to-head
+    (backend activity-id head-id &key expected-revision)
+  "Explicitly open/resume a separate portion here; do not summon any windows."
+  (%head-for-id backend head-id)
+  (let ((world (x11-backend-world backend)))
+    (find-activity world activity-id)
+    (when (and expected-revision (/= expected-revision (world-revision world))) (error 'stale-transition-plan))
+    ;; Check before recording intent: a failed extension is not a mode change.
+    (let ((report (preflight-activity-draft world head-id activity-id :default-layout (configured-default-layout backend))))
+      (unless (activation-report-ready-p report) (error 'activation-blocked :report report)))
+    (let ((p (open-activity-draft world head-id activity-id :default-layout (configured-default-layout backend))))
+      (%set-activity-navigation backend activity-id :extended nil)
+      (%apply-command-result backend p))))
+
+(defun backend-make-activity-portable (backend activity-id head-id &key expected-revision)
+  "Keep this portion as the portable arrangement; never silently gather others.
+Other portions must be empty and inactive. Saved checkpoints remain untouched."
+  (%head-for-id backend head-id)
+  (let* ((world (x11-backend-world backend))
+         (p (activity-draft-for-head world activity-id head-id)))
+    (find-activity world activity-id)
+    (when (and expected-revision (/= expected-revision (world-revision world))) (error 'stale-transition-plan))
+    (unless p (error 'invalid-transition :description "Open the Activity here before making it portable."))
+    (when (some (lambda (other) (and (not (eq p other))
+                                   (or (presentation-placements other) (presentation-active-p world other))))
+                (activity-presentations world activity-id))
+      (error 'invalid-transition
+             :description "Other portions still contain windows or are displayed. Move/hide their windows and switch those monitors away first."))
+    ;; Empty historical portions no longer claim checkpoint source labels, but
+    ;; their saved View definitions (including empty Views) remain unchanged.
+    (dolist (other (activity-presentations world activity-id))
+      (when (and (not (eq p other)) (presentation-source-view-id other))
+        (setf (presentation-source-view-id other) nil (presentation-dirty-p other) t)
+        (lime.core::%touch world)))
+    (%set-activity-navigation backend activity-id :portable (presentation-id p))
+    (when (x11-backend-display backend) (render-head-bars backend))
+    p))

src/x11/appearance.lisp

@@ -0,0 +1,120 @@
+(in-package #:lime.x11)
+
+;;;; Window styling belongs to the adapter, not saved layout intent.
+
+(defstruct window-appearance
+  (border-width 0)
+  (focused-border "#ffffff")
+  (unfocused-border "#444444")
+  (inner-gap 0)
+  (outer-gap 0))
+
+(defparameter *default-window-appearance* (make-window-appearance))
+
+(defun %window-appearance (backend)
+  (or (x11-backend-window-appearance backend) *default-window-appearance*))
+
+(defun %validate-window-appearance (appearance)
+  (unless (and (typep appearance 'window-appearance)
+               (every (lambda (value) (typep value '(integer 0 65535)))
+                      (list (window-appearance-border-width appearance)
+                            (window-appearance-inner-gap appearance)
+                            (window-appearance-outer-gap appearance)))
+               (every (lambda (color)
+                        (and (stringp color) (= (length color) 7)
+                             (char= (char color 0) #\#)
+                             (every (lambda (c) (digit-char-p c 16))
+                                    (subseq color 1))))
+                      (list (window-appearance-focused-border appearance)
+                            (window-appearance-unfocused-border appearance))))
+    (error 'invalid-transition
+           :description "Appearance requires integer pixel sizes from 0 to 65535 and #RRGGBB border colors."))
+  appearance)
+
+(defun %gap-axis (position extent area-position area-extent inner outer)
+  "Inset one tile axis, splitting odd inner gaps without rounding drift."
+  (let* ((before (if (= position area-position) outer (ceiling inner 2)))
+         (after (if (= (+ position extent) (+ area-position area-extent))
+                    outer (floor inner 2)))
+         ;; Even an absurd gap setting must leave a usable one-pixel client.
+         (available (max 0 (1- extent)))
+         (total (+ before after)))
+    (when (> total available)
+      (setf before (floor (* before available) total)
+            after (- available before)))
+    (values (+ position before) (max 1 (- extent before after)))))
+
+(defun %styled-client-geometry (backend client-id geometry work-area tiled-p
+                                &key visible-tile-count)
+  "Return content geometry and border width, fitting the complete outer frame.
+
+Gaps apply only to tiles. A Head's sole visible tile has neither gaps nor
+borders in any layout, including monocle. It still respects the work area
+and normal hints (unlike true fullscreen).
+Size hints may shrink a tile but cannot push it into its neighbor. Floats
+retain their borders and may grow to their hints within the work area."
+  (let* ((style (%window-appearance backend))
+         (sole-tile-p (and tiled-p (eql visible-tile-count 1)))
+         (gapped-p (and tiled-p (not sole-tile-p)))
+         (inner (if gapped-p (window-appearance-inner-gap style) 0))
+         (outer (if gapped-p (window-appearance-outer-gap style) 0)))
+    (multiple-value-bind (x width)
+        (%gap-axis (geometry-x geometry) (geometry-width geometry)
+                   (x11-work-area-x work-area) (x11-work-area-width work-area)
+                   inner outer)
+      (multiple-value-bind (y height)
+          (%gap-axis (geometry-y geometry) (geometry-height geometry)
+                     (x11-work-area-y work-area) (x11-work-area-height work-area)
+                     inner outer)
+        (let* ((border (min (if sole-tile-p 0 (window-appearance-border-width style))
+                            (floor (1- (min width height)) 2)))
+               (content (make-geometry :x x :y y :width (- width (* 2 border))
+                                       :height (- height (* 2 border))))
+               (info (backend-client-icccm-info backend client-id)))
+          (values
+           (constrain-geometry-to-normal-hints
+            content (and info (icccm-client-info-normal-hints info))
+            :bounds-x (if tiled-p x (x11-work-area-x work-area))
+            :bounds-y (if tiled-p y (x11-work-area-y work-area))
+            :bounds-width (if tiled-p (geometry-width content)
+                              (max 1 (- (x11-work-area-width work-area) (* 2 border))))
+            :bounds-height (if tiled-p (geometry-height content)
+                               (max 1 (- (x11-work-area-height work-area) (* 2 border)))))
+           border))))))
+
+(defun %border-pixel (backend color)
+  "Allocate through the actual screen colormap, once per distinct RGB color."
+  (or (gethash color (x11-backend-border-colors backend))
+      (setf (gethash color (x11-backend-border-colors backend))
+            (xlib:alloc-color
+             (xlib:screen-default-colormap (x11-backend-x-screen backend))
+             (xlib:make-color
+              :red (/ (parse-integer color :start 1 :end 3 :radix 16) 255.0)
+              :green (/ (parse-integer color :start 3 :end 5 :radix 16) 255.0)
+              :blue (/ (parse-integer color :start 5 :end 7 :radix 16) 255.0))))))
+
+(defun %prune-border-colors (backend)
+  "Release colors no longer used after a configuration install or rollback."
+  (let* ((style (%window-appearance backend))
+         (used (list (window-appearance-focused-border style)
+                     (window-appearance-unfocused-border style)))
+         (table (x11-backend-border-colors backend)))
+    (maphash (lambda (color pixel)
+               (unless (member color used :test #'equal)
+                 (xlib:free-colors
+                  (xlib:screen-default-colormap (x11-backend-x-screen backend))
+                  (list pixel))
+                 (remhash color table)))
+             table)))
+
+(defun %remember-client-border (backend client-id window)
+  (let ((table (x11-backend-original-border-widths backend)))
+    (unless (nth-value 1 (gethash client-id table))
+      (setf (gethash client-id table) (xlib:drawable-border-width window)))))
+
+(defun %restore-client-border (backend client-id window)
+  (multiple-value-bind (width present-p)
+      (gethash client-id (x11-backend-original-border-widths backend))
+    (when present-p
+      (setf (xlib:drawable-border-width window) width)
+      (remhash client-id (x11-backend-original-border-widths backend)))))

src/x11/attention.lisp

@@ -0,0 +1,103 @@
+(in-package #:lime.x11)
+
+;;;; Live application attention, independent of Activities and checkpoints.
+
+(declaim (ftype function render-head-bars))
+
+(defun backend-client-needs-attention-p (backend client-id)
+  "Whether a managed client currently requests attention through either protocol."
+  (plusp (gethash client-id (x11-backend-attention-clients backend) 0)))
+
+(defun backend-attention-client-ids (backend &key activity-id)
+  "Return unique requesting clients in stable order, optionally scoped to an Activity."
+  (let ((world (x11-backend-world backend)))
+    (sort (loop for activity in (list-activities world)
+                when (or (null activity-id) (equal activity-id (activity-id activity)))
+                  append (remove-if-not
+                          (lambda (id) (backend-client-needs-attention-p backend id))
+                          (if activity-id
+                              (activity-available-client-ids world activity-id)
+                              (copy-list (activity-client-ids activity)))))
+          #'string< :key #'princ-to-string)))
+
+(defun %attention-set-source (backend client-id bit enabled-p)
+  (let* ((table (x11-backend-attention-clients backend))
+         (old (gethash client-id table 0))
+         (new (if enabled-p (logior old bit) (logandc2 old bit))))
+    (if (zerop new) (remhash client-id table) (setf (gethash client-id table) new))
+    (/= old new)))
+
+(defun %attention-wm-hints (window)
+  ;; CLX's WM-HINTS structure does not expose UrgencyHint. Read the wire
+  ;; flags, bounded and type-checked, without discarding fields we don't own.
+  (multiple-value-bind (data type format)
+      (xlib:get-property window :WM_HINTS :type :WM_HINTS :end 9)
+    (declare (ignore type))
+    (and (eql format 32) data)))
+
+(defun %attention-refresh-client (backend client-id window)
+  (let ((hints (%attention-wm-hints window)))
+    (%attention-set-source backend client-id 1 (and hints (logbitp 8 (first hints)))))
+  (%attention-set-source
+   backend client-id 2
+   (member (xlib:intern-atom (x11-backend-display backend) :_NET_WM_STATE_DEMANDS_ATTENTION)
+           (%ewmh-window-state-atoms window) :test #'eql)))
+
+(defun %attention-selected-client-p (backend client-id)
+  "Only the selected, rendered input target counts, not each Head's saved focus.
+
+A palette grab or deliberate root focus is not attention to an application."
+  (let* ((head-id (x11-backend-focused-head-id backend))
+         (presentation (current-presentation (x11-backend-world backend) head-id))
+         (info (backend-client-icccm-info backend client-id)))
+    (and (not (x11-backend-focus-root-override-p backend))
+         (not (x11-backend-ui-session backend))
+         info (eq :normal (icccm-client-info-wm-state info))
+         (or (icccm-client-info-accepts-input-p info)
+             (icccm-client-info-take-focus-p info))
+         (equal client-id (or (ewmh-fullscreen-client-id-for-head backend head-id)
+                              (and presentation (presentation-focus-client-id presentation))))
+         (equal head-id (ewmh-active-head-id-for-client backend client-id)))))
+
+(defun %attention-acknowledge-client (backend client-id)
+  "Clear only attention hints when the user attends to this window."
+  (when (and (backend-client-needs-attention-p backend client-id)
+             (%attention-selected-client-p backend client-id)
+             (%attention-has-input-focus-p backend client-id))
+    (let ((window (gethash client-id (x11-backend-client-windows backend))))
+      (when window
+        (let ((hints (%attention-wm-hints window)))
+          (when (and hints (logbitp 8 (first hints)))
+            (setf (first hints) (logandc2 (first hints) 256))
+            (xlib:change-property window :WM_HINTS hints :WM_HINTS 32)))
+        (%ewmh-set-window-state-atom backend window :_NET_WM_STATE_DEMANDS_ATTENTION nil)
+        (remhash client-id (x11-backend-attention-clients backend))
+        t))))
+
+(defun %attention-has-input-focus-p (backend client-id)
+  "Verify real X focus, including application-owned child widgets.
+
+This roundtrip runs only for a pending alert, never as an idle poll. In
+particular a failed SetInputFocus or an unanswered WM_TAKE_FOCUS is not an
+acknowledgement. Bound ancestor traversal for unusual client hierarchies."
+  (let ((target (gethash client-id (x11-backend-client-windows backend)))
+        (focus (xlib:input-focus (x11-backend-display backend))))
+    (loop repeat 64
+          while (and target (typep focus 'xlib:window))
+          when (= (xlib:window-id target) (xlib:window-id focus)) return t
+          when (= (xlib:window-id focus) (xlib:window-id (x11-backend-root backend))) return nil
+          do (setf focus (nth-value 1 (xlib:query-tree focus))))))
+
+(defun %attention-acknowledge-selected (backend)
+  ;; Copy first: acknowledgement removes entries. Usually this list is empty.
+  (dolist (id (backend-attention-client-ids backend))
+    (%attention-acknowledge-client backend id)))
+
+(defun %attention-request (backend client-id enabled-p)
+  "Set EWMH attention without changing focus, visibility, leases, or layouts."
+  (let ((window (gethash client-id (x11-backend-client-windows backend))))
+    (when window
+      (%attention-set-source backend client-id 2 enabled-p)
+      (%ewmh-set-window-state-atom backend window :_NET_WM_STATE_DEMANDS_ATTENTION enabled-p)
+      (%attention-acknowledge-client backend client-id)
+      (render-head-bars backend))))

src/x11/backend.lisp

@@ -0,0 +1,669 @@
+(in-package #:lime.x11)
+
+;;;; A deliberately small CLX bridge
+;;;
+;;; This file is not a full ICCCM/EWMH window manager.  It is the first real
+;;; adapter for the model: one X11 root window carries one or more Lime Heads,
+;;; MapRequest creates a client in the selected Head's current Activity, and
+;;; applying live Presentations performs the resulting map/unmap/configure
+;;; effects.
+
+(defstruct x11-head
+  "One configured X11 rectangle rendered as one logical Lime Head."
+  head-id
+  x
+  y
+  width
+  height
+  ;; NIL for a manually configured rectangle. RandR discovery associates a
+  ;; logical Head with an active CRTC and records the output(s) feeding it.
+  ;; Mirrored outputs share one CRTC and therefore one Head.
+  output-id
+  output-ids
+  output-name)
+
+(defstruct x11-work-area
+  "The client-usable rectangle of one X11 Head.
+
+The Head remains the physical output rectangle.  A work area is the small
+adapter-level refinement used by ordinary tiled and floating clients after
+Lime has reserved space for its own Head-local UI.  It deliberately is not a
+core-model concept: saved View geometry stays normalized and portable."
+  x
+  y
+  width
+  height)
+
+(defstruct x11-randr-topology
+  "One observed RandR hardware snapshot, owned by the X11 adapter."
+  major-version
+  minor-version
+  timestamp
+  config-timestamp
+  primary-output-id
+  (outputs '())
+  (heads '()))
+
+(defstruct (x11-backend (:constructor %make-x11-backend))
+  display
+  display-name
+  ;; This is CLX's server-level screen object, not Lime's Head model.
+  x-screen
+  root
+  cursor-set
+  world
+  ;; The first configured Head, retained for single-Head compatibility.
+  head-id
+  ;; The Activity on the focused Head.  MapRequest routing reads the active
+  ;; Presentation directly; this slot is a convenient compatibility snapshot.
+  activity-id
+  ;; Startup policy only; saved Views and existing drafts keep their layouts.
+  (default-layout :master-stack)
+  ;; Head id selected for new-window routing and command targeting.
+  focused-head-id
+  ;; A background click deliberately focuses root without destroying the
+  ;; selected Presentation's saved client focus target.
+  (focus-root-override-p nil)
+  ;; Head id -> X11-HEAD and a stable rendering order for that table.
+  (heads (make-hash-table :test #'equal))
+  (head-ids '())
+  ;; :EXPLICIT, :RANDR, or :FALLBACK. The core knows only stable Head ids.
+  head-source
+  ;; The reusable Head UI owns these override-redirect windows.  Reserving a
+  ;; positive height creates a work area immediately below each bar; zero is
+  ;; an intentionally UI-less configuration for experiments and tests.
+  (head-bars (make-hash-table :test #'equal))
+  (head-bar-height 22)
+  ;; Fast segment functions or managed STATUS-PROVIDER objects. Managed I/O
+  ;; lives off-thread; the bar reads only cached strings while painting.
+  (head-bar-status-providers '())
+  ;; Managed providers cache data off-thread; only this backend draws it.
+  status-runtime
+  ;; Adapter-only styling; saved layouts retain their ungapped rectangles.
+  window-appearance
+  (border-colors (make-hash-table :test #'equal))
+  (original-border-widths (make-hash-table :test #'equal))
+  ;; x11/randr.lisp owns these snapshots. An event only marks topology
+  ;; pending; it never silently reassigns Activities, Views, or Leases.
+  randr-topology
+  (randr-topology-dirty-p nil)
+  ;; An in-progress Super+pointer gesture, owned by x11/pointer.lisp.
+  ;; It is frontend-only state; geometry continues to live in the model.
+  pointer-drag
+  ;; Input bindings are installed by x11/input.lisp and owned by this backend.
+  (keybindings (make-hash-table :test #'equal))
+  last-command-error
+  ;; Bounded diagnostic history and the event being dispatched. The separate
+  ;; resilience module owns error policy; these are never checkpoint state.
+  (diagnostics '())
+  (expected-x-error-count 0)
+  event-context
+  ;; The persistence module owns disk state and worker lifecycle; no CLX
+  ;; resource or config closure is sent to that worker.
+  session-persistence
+  ;; A loaded LIME.CONFIG object, plus the source required for an explicit
+  ;; reload.  Configuration is adapter policy: it never becomes Activity,
+  ;; View, Presentation, or Lease data in the pure world.
+  configuration
+  configuration-source
+  configuration-name
+  ;; x11/ui.lisp owns the ephemeral command-palette session and its
+  ;; override-redirect overlay. Neither value belongs in the core world.
+  ui-session
+  ui-overlay
+  ;; Lime client id -> ICCCM-CLIENT-INFO. X11/ICCCM owns this cache and
+  ;; refreshes it from client properties; the pure model never sees CLX data.
+  (icccm-clients (make-hash-table :test #'equal))
+  ;; Live protocol requests only, never checkpoint or persistence data.
+  ;; ATTENTION owns the source bits: ICCCM urgency and EWMH attention.
+  (attention-clients (make-hash-table :test #'equal))
+  ;; Lime client id -> T for an application-requested EWMH fullscreen state.
+  ;; The target Head is deliberately derived from the client's current Lease,
+  ;; so a fullscreen client follows a legitimate View/Head move without
+  ;; becoming a second, monitor-global workspace concept.
+  (fullscreen-clients (make-hash-table :test #'equal))
+  ;; EWMH compatibility state stays entirely in the adapter.  The supporting
+  ;; window identifies Lime to other desktop clients; CLIENT-ORDER preserves
+  ;; EWMH's initial-map order while EXTERNAL-WINDOWS holds dock/desktop
+  ;; surfaces that must be mapped but must never enter an Activity or View.
+  ewmh-supporting-window
+  (ewmh-client-order '())
+  (ewmh-external-windows (make-hash-table :test #'eql))
+  ;; Lime client id -> recognized _NET_WM_WINDOW_TYPE keywords.  This is
+  ;; metadata used by first-placement policy, not persistent task state.
+  (ewmh-window-types (make-hash-table :test #'equal))
+  ;; Lime client id -> CLX window
+  (client-windows (make-hash-table :test #'equal))
+  ;; XID -> Lime client id
+  (window-clients (make-hash-table :test #'eql))
+  ;; XID -> number of UnmapNotify events caused by Lime's renderer.  ICCCM
+  ;; withdrawal is signaled with the same X event, so lifecycle consumes one
+  ;; of these tokens before treating an unmap as an application withdrawal.
+  (pending-unmaps (make-hash-table :test #'eql))
+  (quit-requested-p nil)
+  (running-p nil))
+
+(defun %ensure-head (world head-id)
+  (handler-case
+      (find-head world head-id)
+    (unknown-entity ()
+      (create-head world head-id))))
+
+(defun %ensure-activity (world activity-id)
+  (handler-case
+      (find-activity world activity-id)
+    (unknown-entity ()
+      (create-activity world activity-id "Scratch"))))
+
+(defun %ensure-active-presentation (world head-id activity-id
+                                     &key (default-layout :master-stack))
+  (%ensure-head world head-id)
+  (%ensure-activity world activity-id)
+  (or (current-presentation world head-id)
+      (open-activity-draft world head-id activity-id :default-layout default-layout)))
+
+(defun %rectangles-overlap-p (first second)
+  (and (< (x11-head-x first)
+          (+ (x11-head-x second) (x11-head-width second)))
+       (< (x11-head-x second)
+          (+ (x11-head-x first) (x11-head-width first)))
+       (< (x11-head-y first)
+          (+ (x11-head-y second) (x11-head-height second)))
+       (< (x11-head-y second)
+          (+ (x11-head-y first) (x11-head-height first)))))
+
+(defun %validate-head (head root)
+  (unless (typep head 'x11-head)
+    (error 'invalid-transition
+           :description "An X11 Head must be an X11-HEAD structure."))
+  (unless (and (x11-head-head-id head)
+               (integerp (x11-head-x head))
+               (integerp (x11-head-y head))
+               (plusp (x11-head-width head))
+               (plusp (x11-head-height head)))
+    (error 'invalid-transition
+           :description "An X11 Head needs an id, integer origin, and positive size."))
+  (unless (and (>= (x11-head-x head) 0)
+               (>= (x11-head-y head) 0)
+               (<= (+ (x11-head-x head) (x11-head-width head))
+                   (xlib:drawable-width root))
+               (<= (+ (x11-head-y head) (x11-head-height head))
+                   (xlib:drawable-height root)))
+    (error 'invalid-transition
+           :description "An X11 Head must fit inside the root window."))
+  head)
+
+(defun %configure-heads (root head-id heads)
+  "Validate explicit Head rectangles or make one rectangle for ROOT."
+  (let ((configured-heads (or heads
+                              (list (make-x11-head :head-id head-id
+                                                   :x 0
+                                                   :y 0
+                                                   :width (xlib:drawable-width root)
+                                                   :height (xlib:drawable-height root)))))
+        (seen (make-hash-table :test #'equal)))
+    (dolist (head configured-heads)
+      (%validate-head head root)
+      (when (gethash (x11-head-head-id head) seen)
+        (error 'invalid-transition
+               :description "Two configured X11 Heads use the same id."))
+      (setf (gethash (x11-head-head-id head) seen) t)
+      (dolist (other configured-heads)
+        (when (and (not (eq head other))
+                   (%rectangles-overlap-p head other))
+          (error 'invalid-transition
+                 :description "Configured X11 Head rectangles may not overlap."))))
+    configured-heads))
+
+(defun %choose-configured-heads (display root head-id heads head-discovery)
+  "Return validated Heads, their source, and an optional RandR snapshot.
+
+An explicit HEADS argument always wins. :AUTO uses RandR when it can find at
+least one active output; :NONE keeps the historical single-root Head fallback.
+This is startup discovery only, not an output-management policy."
+  (unless (member head-discovery '(:auto :none))
+    (error 'invalid-transition
+           :description "HEAD-DISCOVERY must be :AUTO or :NONE."))
+  (cond
+    (heads
+     (values (%configure-heads root head-id heads) :explicit nil))
+    ((eq head-discovery :auto)
+     (let ((topology (x11-randr-discover-topology display root)))
+       (if (and topology (x11-randr-topology-heads topology))
+           (values (%configure-heads root head-id
+                                     (x11-randr-topology-heads topology))
+                   :randr topology)
+           (values (%configure-heads root head-id nil) :fallback nil))))
+    (t
+     (values (%configure-heads root head-id nil) :fallback nil))))
+
+(defun %head-for-id (backend head-id)
+  (or (gethash head-id (x11-backend-heads backend))
+      (error 'invalid-transition
+             :description (format nil "Head ~S has no configured rectangle."
+                                  head-id))))
+
+(defun %head-bar-reserved-height (backend head)
+  "Return the usable reserved bar height for HEAD.
+
+Keep at least one pixel of client area on an unusually tiny test Head; a
+normal X server Head is naturally much larger than the default 22 pixels."
+  (min (max 0 (x11-backend-head-bar-height backend))
+       (max 0 (1- (x11-head-height head)))))
+
+(defun x11-head-work-area (backend head-or-id)
+  "Return HEAD-OR-ID's client work area after Lime's top bar reservation.
+
+Ordinary layouts and floats use this rectangle.  EWMH fullscreen intentionally
+uses the physical X11-HEAD rectangle instead, so games and video players do
+not inherit a decorative gap."
+  (let* ((head (if (x11-head-p head-or-id)
+                   head-or-id
+                   (%head-for-id backend head-or-id)))
+         (bar-height (%head-bar-reserved-height backend head)))
+    (make-x11-work-area :x (x11-head-x head)
+                        :y (+ (x11-head-y head) bar-height)
+                        :width (x11-head-width head)
+                        :height (- (x11-head-height head) bar-height))))
+
+(defun %client-id-for-window (window)
+  (format nil "x11-~X" (xlib:window-id window)))
+
+(defun %backend-client-id (backend window)
+  (gethash (xlib:window-id window) (x11-backend-window-clients backend)))
+
+(defun %registered-window-p (backend window)
+  (%backend-client-id backend window))
+
+(defun %register-window (backend client-id window)
+  (setf (gethash client-id (x11-backend-client-windows backend)) window
+        (gethash (xlib:window-id window)
+                 (x11-backend-window-clients backend)) client-id)
+  client-id)
+
+(defun %forget-window (backend window)
+  (let ((client-id (%backend-client-id backend window)))
+    (when client-id
+      (remhash client-id (x11-backend-client-windows backend))
+      (remhash (xlib:window-id window)
+               (x11-backend-window-clients backend)))
+    client-id))
+
+(defun %unmap-window-id (window-or-id)
+  "Return an XID for WINDOW-OR-ID, which may be useful in server-free tests."
+  (if (integerp window-or-id)
+      window-or-id
+      (xlib:window-id window-or-id)))
+
+(defun %note-pending-unmap (backend window-or-id)
+  "Record one renderer-originated unmap before issuing it to the X server."
+  (let* ((window-id (%unmap-window-id window-or-id))
+         (pending-unmaps (x11-backend-pending-unmaps backend)))
+    (incf (gethash window-id pending-unmaps 0))
+    window-id))
+
+(defun %consume-pending-unmap-p (backend window-or-id)
+  "Consume one renderer-originated unmap token, returning whether one existed."
+  (let* ((window-id (%unmap-window-id window-or-id))
+         (pending-unmaps (x11-backend-pending-unmaps backend))
+         (count (gethash window-id pending-unmaps 0)))
+    (when (plusp count)
+      (if (= count 1)
+          (remhash window-id pending-unmaps)
+          (setf (gethash window-id pending-unmaps) (1- count)))
+      t)))
+
+(defun %forget-pending-unmaps (backend window-or-id)
+  "Discard stale renderer-unmap bookkeeping for a gone window."
+  (remhash (%unmap-window-id window-or-id) (x11-backend-pending-unmaps backend)))
+
+;; These implementations live in focused modules loaded after the backend.
+;; Keeping the declarations here lets this file own connection setup and the
+;; event loop without turning it into a renderer or lifecycle policy bucket.
+(declaim (ftype function manage-window
+                         %prepare-session-persistence
+                         %adopt-session-clients
+                         %poll-session-persistence
+                         %stop-session-persistence
+                         %forget-navigation-state
+                         %handle-display-error
+                         %call-with-client-race-handling
+                         %call-with-cleanup-diagnostics
+                         backend-release-input
+                         %handle-configure-request
+                         %handle-destroy-notify
+                         %handle-unmap-notify
+                         %handle-property-notify
+                         icccm-set-client-state
+                         icccm-withdraw-client
+                         icccm-handle-client-message
+                         x11-randr-discover-topology
+                         x11-randr-topology-heads
+                         x11-randr-enable-notifications
+                         x11-randr-handle-change
+                         ewmh-initialize
+                         ewmh-shutdown
+                         ewmh-handle-client-message
+                         initialize-head-bars
+                         shutdown-head-bars
+                         %handle-head-bar-exposure
+                         %handle-head-bar-button-press
+                         %handle-head-bar-motion
+                         %handle-head-bar-leave
+                         %initialize-pointer-cursors
+                         %shutdown-pointer-cursors
+                         %shutdown-cursor-session-settings
+                         %handle-cursor-settings-selection-clear
+                         %handle-button-press
+                         %handle-button-release
+                         %handle-motion-notify
+                         %coalesce-drag-motion
+                         %handle-key-press
+                         %handle-ui-key-press
+                         %handle-ui-button-press
+                         %handle-ui-motion
+                         %handle-ui-leave
+                         %handle-ui-exposure
+                         backend-close-command-palette
+                         install-default-keybindings))
+
+(defun start-backend (&key display-name
+                           (world (make-world) world-supplied-p)
+                           session-file
+                           (head-id "x11-root")
+                           (activity-id "scratch")
+                           (default-layout :master-stack)
+                           heads
+                           (head-discovery :auto)
+                           (head-bar-height 22)
+                           (install-default-keybindings-p t)
+                           (keybinding-modifiers '(:mod-4)))
+  "Claim one X11 root window and return a Lime backend.
+
+DISPLAY-NAME follows the normal DISPLAY syntax, e.g. ":1" for a Xephyr
+server.  Start this only in a nested server or another X11 session without an
+existing window manager: selecting :SUBSTRUCTURE-REDIRECT is exclusive.
+
+HEADS is an optional list of non-overlapping X11-HEAD rectangles. Each
+rectangle becomes one Head. Without it, the root window is one Head named
+by HEAD-ID unless HEAD-DISCOVERY is :AUTO and RandR reports active outputs.
+In that normal case each active CRTC becomes one Head named for its output;
+mirrored outputs share a single Head. Set HEAD-DISCOVERY to :NONE to force the
+single-root fallback.
+
+SESSION-FILE is NIL for a fresh nonpersistent backend, :DEFAULT for the
+display-specific XDG state path, or a pathname. It cannot be combined with an
+explicit WORLD. Restored clients retain their verified draft/checkpoint roles.
+
+HEAD-BAR-HEIGHT reserves that many pixels at the top of each Head for Lime's
+first reusable UI surface.  Set it to zero to run without bars and use the
+full physical Head as the ordinary client area.
+
+Lime creates the bootstrap Scratch Activity with an unsaved blank live draft
+on each initial Head in DEFAULT-LAYOUT (:MASTER-STACK by default); it does not
+manufacture permanent empty Views or change an existing draft's layout. Unless
+INSTALL-DEFAULT-KEYBINDINGS-P is NIL, Lime installs its small Super starter
+map before returning. KEYBINDING-MODIFIERS accepts the same modifier list or
+integer mask as BIND-KEY; set the flag to NIL for a fully custom map."
+  (unless (member default-layout '(:manual :master-stack :monocle))
+    (error 'invalid-transition
+           :description "DEFAULT-LAYOUT must be :MANUAL, :MASTER-STACK, or :MONOCLE."))
+  (when (and session-file world-supplied-p)
+    (error "Choose an explicit WORLD or SESSION-FILE, not both."))
+  (let* ((display (xlib:open-default-display display-name))
+         (x-screen (xlib:display-default-screen display))
+         (root (xlib:screen-root x-screen)))
+    (unless (and (integerp head-bar-height) (not (minusp head-bar-height)))
+      (error 'invalid-transition
+             :description "HEAD-BAR-HEIGHT must be a non-negative integer."))
+    (multiple-value-bind (configured-heads head-source randr-topology)
+        (%choose-configured-heads display root head-id heads head-discovery)
+      (let* ((primary-head-id (x11-head-head-id (first configured-heads)))
+             (head-table (make-hash-table :test #'equal))
+             (backend (%make-x11-backend :display display :display-name (or display-name (uiop:getenv "DISPLAY"))
+                                         :x-screen x-screen
+                                         :root root
+                                         :world world
+                                         :head-id primary-head-id
+                                         :activity-id activity-id
+                                         :default-layout default-layout
+                                         :focused-head-id primary-head-id
+                                         :heads head-table
+                                         :head-ids (mapcar #'x11-head-head-id
+                                                            configured-heads)
+                                         :head-source head-source
+                                         :randr-topology randr-topology
+                                         :head-bar-height head-bar-height)))
+      ;; Request-specific race handling never suppresses root ownership or
+      ;; key-grab conflicts. Synchronous failed queries must unwind, not wait
+      ;; forever for a reply the server will never send.
+      (setf (xlib:display-error-handler display)
+            (lambda (error-display error-key &rest key-vals)
+              (apply #'%handle-display-error backend error-display error-key
+                     key-vals)))
+      (dolist (head configured-heads)
+        (setf (gethash (x11-head-head-id head) head-table) head))
+      (handler-case
+          (progn
+          ;; BadAccess is reported by the X server if another WM already owns
+          ;; this root. Finish the roundtrip before changing shared root state.
+          (setf (xlib:window-event-mask root)
+                '(:substructure-redirect :substructure-notify :button-press))
+          (xlib:display-finish-output display)
+          (%prepare-session-persistence backend session-file)
+          (setf world (x11-backend-world backend))
+          (%initialize-pointer-cursors backend)
+          (when (eq head-source :randr)
+            (x11-randr-enable-notifications backend))
+          (dolist (head configured-heads)
+            (%ensure-active-presentation
+             world
+             (x11-head-head-id head)
+             activity-id :default-layout default-layout))
+          (setf (x11-backend-activity-id backend)
+                (presentation-activity-id
+                 (current-presentation world (x11-backend-focused-head-id backend))))
+          (ewmh-initialize backend)
+          ;; Create the Head UI before adopting existing clients.  Subsequent
+          ;; render passes raise it again after client reconciliation.
+          (initialize-head-bars backend)
+          (%adopt-session-clients backend)
+          (dolist (window (multiple-value-bind (children parent root-window)
+                              (xlib:query-tree root)
+                            (declare (ignore parent root-window))
+                            children))
+            (%call-with-client-race-handling
+             backend
+             (lambda ()
+               (when (and (not (%registered-window-p backend window))
+                          (not (eq (xlib:window-override-redirect window) :on))
+                          (eq (xlib:window-map-state window) :viewable))
+                 (manage-window backend window)))))
+          (when session-file (apply-active-presentation backend))
+          (when install-default-keybindings-p
+            (install-default-keybindings backend
+                                         :modifiers keybinding-modifiers))
+          backend)
+        (error (condition)
+          (ignore-errors (%stop-session-persistence backend nil))
+          (%forget-navigation-state backend)
+          (xlib:close-display display :abort t)
+          (error condition)))))))
+
+(defun run-event-loop (backend &key (timeout 0.1) before-event)
+  "Process CLX events until STOP-BACKEND clears BACKEND's running flag.
+
+BEFORE-EVENT, when supplied, runs at an event-loop boundary before waiting for
+the next X event. The ordinary adapter leaves it NIL; LIME.DEV uses the hook
+to serialize REPL requests on this X-owning thread rather than letting a
+remote REPL race CLX or the Activity/View world."
+  (setf (x11-backend-running-p backend) t
+        (x11-backend-quit-requested-p backend) nil)
+  (loop while (x11-backend-running-p backend)
+        do (when before-event
+             (funcall before-event backend))
+           ;; A control request may have asked to quit at this boundary.
+           (unless (x11-backend-running-p backend) (return))
+           (%poll-session-persistence backend)
+           (%call-with-client-race-handling
+            backend (lambda () (%dispatch-next-event backend timeout))))
+  backend)
+
+(defun %dispatch-next-event (backend timeout)
+  "Handle at most one event so busy clients cannot starve the control mailbox."
+  (setf (x11-backend-event-context backend) '(:kind :wait))
+  (xlib:event-case ((x11-backend-display backend)
+                    :timeout timeout
+                    :discard-p t
+                    :force-output-p t)
+    (:map-request (window)
+      (%note-backend-event backend :map-request window)
+      (manage-window backend window)
+      t)
+    (:configure-request (parent window above-sibling x y width height
+                         border-width value-mask)
+      (%note-backend-event backend :configure-request window)
+      (%handle-configure-request backend window x y width height
+                                 border-width value-mask
+                                 parent above-sibling)
+      t)
+    (:client-message (window type format data)
+      (%note-backend-event backend :client-message window)
+      ;; ICCCM owns WM_CHANGE_STATE; the narrow EWMH slice owns its
+      ;; own atoms.  Keeping both calls separate avoids turning the
+      ;; EWMH module into a catch-all client-message dispatcher.
+      (unless (%handle-status-notification backend window type)
+        (unless (icccm-handle-client-message backend window type format data)
+          (ewmh-handle-client-message backend window type format data)))
+      t)
+    (:rr-screen-change-notify ()
+      (%note-backend-event backend :randr)
+      (x11-randr-handle-change backend)
+      t)
+    (:rr-crtc-change-notify ()
+      (%note-backend-event backend :randr)
+      (x11-randr-handle-change backend)
+      t)
+    (:rr-output-change-notify ()
+      (%note-backend-event backend :randr)
+      (x11-randr-handle-change backend)
+      t)
+    (:key-press (code state)
+      (%note-backend-event backend :key-press)
+      (if (x11-backend-ui-session backend)
+          (%handle-ui-key-press backend code state)
+          (%handle-key-press backend code state))
+      t)
+    (:exposure (window count)
+      (%note-backend-event backend :exposure window)
+      (unless (%handle-head-bar-exposure backend window count)
+        (%handle-ui-exposure backend window count))
+      t)
+    (:button-press (window root-x root-y code state time)
+      (%note-backend-event backend :button-press window)
+      (unless (%handle-ui-button-press backend window root-x root-y code)
+        (unless (%handle-head-bar-button-press backend window root-x root-y
+                                                code state time)
+          (%handle-button-press backend window root-x root-y code state time)))
+      t)
+    (:button-release (code root-x root-y)
+      (%note-backend-event backend :button-release)
+      (%handle-button-release backend code root-x root-y)
+      t)
+    (:motion-notify (window root-x root-y state)
+      (%note-backend-event backend :motion-notify window)
+      (unless (%handle-ui-motion backend window root-x root-y)
+        (unless (%handle-head-bar-motion backend window root-x root-y)
+          (when (x11-backend-pointer-drag backend)
+            (multiple-value-bind (latest-x latest-y)
+                (%coalesce-drag-motion backend window root-x root-y state)
+              (%handle-motion-notify backend latest-x latest-y state)))))
+      t)
+    (:enter-notify (window root-x root-y)
+      (%note-backend-event backend :enter-notify window)
+      (unless (%handle-ui-motion backend window root-x root-y)
+        (%handle-head-bar-motion backend window root-x root-y))
+      t)
+    (:leave-notify (window)
+      (%note-backend-event backend :leave-notify window)
+      (%handle-ui-leave backend window)
+      (%handle-head-bar-leave backend window)
+      t)
+    (:destroy-notify (window)
+      (%note-backend-event backend :destroy-notify window)
+      (%handle-destroy-notify backend window)
+      t)
+    (:unmap-notify (event-window window configure-p)
+      (%note-backend-event backend :unmap-notify window)
+      (%handle-unmap-notify backend event-window window configure-p)
+      t)
+    (:property-notify (window atom)
+      (%note-backend-event backend :property-notify window)
+      (%handle-property-notify backend window atom)
+      t)
+    (:selection-clear (window selection)
+      (%note-backend-event backend :selection-clear window)
+      (%handle-cursor-settings-selection-clear backend window selection)
+      t)
+    (:focus-in (window mode)
+      (%note-backend-event backend :focus-in window)
+      ;; Globally-active clients can answer WM_TAKE_FOCUS asynchronously.
+      ;; Grab/ungrab notifications alone are not user acknowledgement.
+      (when (eq mode :normal)
+        (let ((id (%backend-client-id backend window)))
+          (when (and id (%attention-acknowledge-client backend id))
+            (render-head-bars backend))))
+      t)
+    (otherwise () t)))
+
+(defun %note-backend-event (backend kind &optional window)
+  ;; CLX keeps the current event queued when a handler unwinds, even with
+  ;; :DISCARD-P T. Mark it consumed before mutating state: a stale MapRequest
+  ;; must not loop forever, and a failed command must not replay on resume.
+  ;; Other queued events remain intact.
+  (xlib:discard-current-event (x11-backend-display backend))
+  (setf (x11-backend-event-context backend)
+        (list :kind kind :window-id (and window (xlib:window-id window)))))
+
+(defun stop-backend (backend &key (save-session-p t))
+  "Remap managed clients, release the root selection, and close CLX cleanly."
+  (when (x11-backend-running-p backend)
+    (setf (x11-backend-running-p backend) nil))
+  (let ((display (x11-backend-display backend)))
+    (when display
+      ;; Each cleanup is independent: a stale resource must not prevent the
+      ;; next client's restoration or the final connection close.
+      (flet ((cleanup (function)
+               (%call-with-cleanup-diagnostics backend function)))
+        (unwind-protect
+             (progn
+               (cleanup (lambda () (%stop-session-persistence backend save-session-p)))
+               (cleanup (lambda () (%forget-navigation-state backend)))
+               (cleanup (lambda () (%shutdown-status-runtime backend)))
+               (cleanup (lambda () (backend-release-input backend)))
+               (cleanup (lambda () (ewmh-shutdown backend)))
+               (cleanup (lambda () (shutdown-head-bars backend)))
+               (cleanup (lambda () (%shutdown-cursor-session-settings backend)))
+               (cleanup (lambda () (%shutdown-pointer-cursors backend)))
+               (maphash (lambda (client-id window)
+                 ;; Leave the server in the conventional visible state before
+                 ;; Lime relinquishes ownership of the root.
+                 (cleanup (lambda ()
+                            (icccm-set-client-state backend client-id window :normal :force-p t)
+                            (%restore-client-border backend client-id window)
+                            (xlib:map-window window))))
+                        (x11-backend-client-windows backend))
+               (cleanup (lambda () (xlib:display-finish-output display))))
+          (unwind-protect
+               (cleanup (lambda () (xlib:close-display display :abort t)))
+            (setf (x11-backend-display backend) nil))))))
+  backend)
+
+(defun run-demo (&key display-name)
+  "Start the adapter and run it until interrupted.
+
+Use this in Xephyr, then launch xterms into the same nested DISPLAY."
+  (let ((backend (start-backend :display-name display-name)))
+    (unwind-protect
+         (run-event-loop backend)
+      (stop-backend backend))))

src/x11/bar.lisp

@@ -0,0 +1,774 @@
+(in-package #:lime.x11)
+
+;;;; Reusable Head bar
+;;;
+;;; This is Lime's first persistent UI surface.  It intentionally knows only
+;;; about adapter facts (physical Head rectangles, ICCCM titles, X11 windows)
+;;; plus the public model snapshot it is rendering.  The command palette is a
+;;; separate temporary overlay; both can evolve behind a later theme/renderer
+;;; boundary without making UI state part of Activities, Views, or Leases.
+
+(defstruct head-bar-style
+  "Adapter-only bar appearance. NIL TITLE-EDGE-COLOR disables the two hairlines."
+  (padding-x 10)
+  (background "#060a0c")
+  (foreground "#ffdbb0")
+  (focused-background "#121f25")
+  (focused-foreground "#ffac54")
+  (unfocused-background "#0b1216")
+  (unfocused-foreground "#a8adb0")
+  ;; NIL preserves the original shared colors for existing configurations.
+  accent-color
+  menu-label-color
+  logo-color
+  (separator-color "#b88755")
+  (attention-color "#ffac54")
+  (attention-marker "!")
+  (attention-indicator-p t)
+  (title-edge-color "#40535d"))
+
+(defparameter *default-head-bar-style* (make-head-bar-style))
+
+(declaim (ftype function lime-configuration-bar-style))
+
+(defun %head-bar-style (backend)
+  (declare (notinline lime-configuration-bar-style))
+  (let ((configuration (x11-backend-configuration backend)))
+    (if configuration (lime-configuration-bar-style configuration)
+        *default-head-bar-style*)))
+
+(defun %head-bar-style-colors (style)
+  (remove nil (list (head-bar-style-background style)
+                    (head-bar-style-foreground style)
+                    (head-bar-style-focused-background style)
+                    (head-bar-style-focused-foreground style)
+                    (head-bar-style-unfocused-background style)
+                    (head-bar-style-unfocused-foreground style)
+                    (head-bar-style-accent-color style)
+                    (head-bar-style-menu-label-color style)
+                    (head-bar-style-logo-color style)
+                    (head-bar-style-separator-color style)
+                    (head-bar-style-attention-color style)
+                    (head-bar-style-title-edge-color style))))
+
+(defun %validate-head-bar-style (style)
+  (unless (and (typep style 'head-bar-style)
+               (integerp (head-bar-style-padding-x style))
+               (<= 0 (head-bar-style-padding-x style) 128))
+    (error 'invalid-transition :description "Bar :PADDING-X must be an integer from 0 to 128 pixels."))
+  (unless (and (stringp (head-bar-style-attention-marker style))
+               (<= 1 (length (head-bar-style-attention-marker style)) 16)
+               (notany (lambda (c) (or (< (char-code c) 32) (= (char-code c) 127)))
+                       (head-bar-style-attention-marker style))
+               (member (head-bar-style-attention-indicator-p style) '(nil t)))
+    (error 'invalid-transition :description "Bar attention marker must be 1–16 printable characters; :ATTENTION-INDICATOR-P must be T or NIL."))
+  (flet ((rgb-p (color)
+           (and (stringp color) (= (length color) 7)
+                (char= (char color 0) #\#)
+                (every (lambda (c) (digit-char-p c 16)) (subseq color 1)))))
+    (unless (and (typep style 'head-bar-style)
+                 (every #'rgb-p
+                        (list (head-bar-style-background style)
+                              (head-bar-style-foreground style)
+                              (head-bar-style-focused-background style)
+                              (head-bar-style-focused-foreground style)
+                              (head-bar-style-unfocused-background style)
+                              (head-bar-style-unfocused-foreground style)
+                              (head-bar-style-attention-color style)
+                              (head-bar-style-separator-color style)))
+                 (every (lambda (color) (or (null color) (rgb-p color)))
+                        (list (head-bar-style-title-edge-color style)
+                              (head-bar-style-accent-color style)
+                              (head-bar-style-menu-label-color style)
+                              (head-bar-style-logo-color style))))
+      (error 'invalid-transition
+             :description "Bar colors must be #RRGGBB; :TITLE-EDGE-COLOR, :ACCENT-COLOR, :MENU-LABEL-COLOR, and :LOGO-COLOR may be NIL.")))
+  style)
+
+(defun %ui-accent-color (style)
+  (or (head-bar-style-accent-color style) (head-bar-style-focused-foreground style)))
+
+(defun %ui-menu-label-color (style)
+  (or (head-bar-style-menu-label-color style) (head-bar-style-separator-color style)))
+
+(defstruct head-bar-segment
+  "One optional right-side status item supplied by user configuration.
+
+TEXT is rendered as one independently shaped item. CLICK-ACTION, when present,
+is a function of (BACKEND HEAD-ID), allowing music, volume, clock, or
+other modules to opt into bar interaction without teaching the core about
+them."
+  id
+  text
+  ;; Optional pixel budget; fitting remains grapheme-aware in the renderer.
+  maximum-width
+  ;; NIL inherits the bar foreground. This also permits data-dependent colors
+  ;; from a user formatter without embedding markup in application text.
+  foreground
+  ;; Optional separately colored logical prefix (typically an icon). The
+  ;; complete text stays one shaped/clickable item, including RTL labels.
+  (prefix-length 0)
+  prefix-foreground
+  click-action)
+
+(defun %bar-color-p (color)
+  (and (stringp color) (= (length color) 7) (char= (char color 0) #\#)
+       (every (lambda (c) (digit-char-p c 16)) (subseq color 1))))
+
+(defun %validate-head-bar-segment (segment)
+  (unless (and (typep segment 'head-bar-segment)
+               (or (null (head-bar-segment-foreground segment))
+                   (%bar-color-p (head-bar-segment-foreground segment)))
+               (or (null (head-bar-segment-prefix-foreground segment))
+                   (%bar-color-p (head-bar-segment-prefix-foreground segment)))
+               (integerp (head-bar-segment-prefix-length segment))
+               (<= 0 (head-bar-segment-prefix-length segment)
+                   (length (%single-line-text (head-bar-segment-text segment))))
+               (or (null (head-bar-segment-maximum-width segment))
+                   (and (integerp (head-bar-segment-maximum-width segment))
+                        (plusp (head-bar-segment-maximum-width segment))))
+               (or (null (head-bar-segment-click-action segment))
+                   (functionp (head-bar-segment-click-action segment))))
+    (error 'invalid-transition :description "A status segment needs optional #RRGGBB colors, a prefix length within its text, positive pixel width, and function click action."))
+  segment)
+
+(defstruct x11-head-bar-hit-region
+  left
+  right
+  action)
+
+(defstruct x11-head-bar
+  head-id
+  window
+  font
+  canvas
+  background-gcontext
+  foreground-gcontext
+  inverse-foreground-gcontext
+  colormap
+  (colors (make-hash-table :test #'equal))
+  height
+  pointer-hand-p
+  (hit-regions '()))
+
+;; These public commands live in later files in ASDF load order.  The bar
+;; invokes them only in response to user input, after the system is loaded.
+(declaim (ftype function backend-open-command-palette
+                         backend-open-attention-picker
+                         backend-open-activity-picker
+                         %show-navigation-result
+                         %ui-request-activity-activation
+                         %set-ui-pointer
+                         %ui-window-pointer-position
+                         backend-cycle-layout))
+
+(defun %bar-string (value)
+  (princ-to-string value))
+
+(defun %bar-text-width (font text)
+  "Measure the same shaped run used for painting, with no X roundtrip."
+  (%text-width font text))
+
+(defun %bar-short-text (text maximum-width measure)
+  "Server-free compatibility entry; real UI fitting supplies grapheme boundaries."
+  (%fit-text text maximum-width measure))
+
+(defun %bar-text-layout (width label layout-token title status measure
+                         &key (padding-x 10) (fit #'%bar-short-text) (status-fit fit)
+                           (label-fit fit) (minimum-label-width 0))
+  "Compute text and positions once for both drawing and hit testing.
+
+MEASURE accepts a string and returns pixel width. Keeping this calculation
+server-free makes proportional-font and narrow-Head behavior testable."
+  (let* ((gap 8)
+         (title-padding (1+ padding-x)) ; leave the hairline separate from text padding
+         (separator " | ")
+         (separator-width (funcall measure separator))
+         (logo-x (min width padding-x))
+         ;; The separator already supplies the inter-field space. Keep outer
+         ;; edge padding, without adding a second blank after the logo.
+         (logo-width (min width (+ padding-x (funcall measure "Lime"))))
+         (logo (funcall fit "Lime" (max 0 (- logo-width padding-x)) measure))
+         (left-x (min width (+ logo-width separator-width)))
+         (right-edge (max left-x (- width padding-x)))
+         (available (- right-edge left-x))
+         (visible-layout (funcall fit layout-token available measure))
+         (layout-width (funcall measure visible-layout))
+         ;; Preserve the layout control even if a status provider is verbose.
+         (status-limit (max 0 (- available layout-width
+                                 (min minimum-label-width (floor available 3))
+                                 (if (plusp minimum-label-width) separator-width 0)
+                                 (if (plusp layout-width) gap 0)))))
+    (multiple-value-bind (visible-status status-prefix-length measured-status-width status-runs)
+        (funcall status-fit status status-limit measure)
+      (let* ((status-width (or measured-status-width (funcall measure visible-status)))
+             (status-x (- right-edge status-width))
+             (left-limit (max left-x (- status-x (if (plusp status-width) gap 0))))
+             (label-room (max 0 (- left-limit left-x layout-width
+                                   (if (plusp layout-width) separator-width 0))))
+             (label-limit (max (min minimum-label-width label-room)
+                              (- label-room
+                                    ;; Reserve title padding and some useful text.
+                                    (if (plusp (length title)) (+ 80 (* 2 title-padding) gap) 0))))
+             (label-result (multiple-value-list (funcall label-fit label label-limit measure)))
+             (visible-label (first label-result))
+             (label-width (or (third label-result) (funcall measure visible-label)))
+             (layout-x (+ left-x label-width
+                           (if (and (plusp label-width) (plusp layout-width))
+                               separator-width 0)))
+             (title-left (min left-limit (+ layout-x layout-width
+                                           (if (plusp layout-width) gap 0))))
+             (title-right (if (plusp status-width) left-limit width))
+             (title-x (min title-right (+ title-left title-padding)))
+             (title-width (max 0 (- title-right title-padding title-x)))
+             (visible-title (funcall fit title title-width measure))
+             (separators
+               (append
+                (when (and (or (plusp label-width) (plusp layout-width))
+                           (<= (+ logo-width separator-width) width))
+                  (list (cons logo-width separator)))
+                (when (and (plusp label-width) (plusp layout-width))
+                  (list (cons (+ left-x label-width) separator))))))
+        (list :logo logo :logo-x logo-x :logo-width logo-width
+              :label visible-label :label-x left-x
+              :label-runs (fourth label-result)
+              :layout-token visible-layout :layout-x layout-x
+              :title visible-title :title-x title-x :title-width title-width
+              :title-left title-left :title-right title-right :separators separators
+              :status visible-status :status-x status-x
+              :status-runs status-runs
+              :status-prefix-length status-prefix-length)))))
+
+(defun %bar-status-separator-spans (segments prefix-length start-x measure)
+  "Locate only real, visible inter-item separators, never pipes in item text."
+  (let ((offset 0) (x start-x) (spans '()))
+    (loop for segment in segments
+          for first-p = t then nil
+          do (unless first-p
+               (let* ((n (min 3 (max 0 (- prefix-length offset))))
+                      (text (subseq " | " 0 n)))
+                 (when (plusp n) (push (cons x text) spans))
+                 (incf offset 3)
+                 (incf x (funcall measure " | "))))
+             (when (>= offset prefix-length) (return))
+             (let ((text (%bar-string (head-bar-segment-text segment))))
+               (incf offset (length text))
+               (incf x (funcall measure text))))
+    (nreverse spans)))
+
+(defun %bar-pixel (bar color)
+  (or (gethash color (x11-head-bar-colors bar))
+      (setf (gethash color (x11-head-bar-colors bar))
+            (xlib:alloc-color
+             (x11-head-bar-colormap bar)
+             (xlib:make-color
+              :red (/ (parse-integer color :start 1 :end 3 :radix 16) 255.0)
+              :green (/ (parse-integer color :start 3 :end 5 :radix 16) 255.0)
+              :blue (/ (parse-integer color :start 5 :end 7 :radix 16) 255.0))))))
+
+(defun %prune-head-bar-colors (bar style)
+  (let ((used (%head-bar-style-colors style)))
+    (maphash (lambda (color pixel)
+               (unless (member color used :test #'equal)
+                 (xlib:free-colors (x11-head-bar-colormap bar) (list pixel))
+                 (remhash color (x11-head-bar-colors bar))))
+             (x11-head-bar-colors bar))))
+
+(defun %bar-status-hit-spans (segments prefix-length start-x measure)
+  "Return (LEFT RIGHT SEGMENT) for clickable, actually displayed status text.
+
+Separators, truncation dots, and entirely clipped segments remain inert."
+  (let ((offset 0) (x start-x) (spans '()))
+    (loop for segment in segments
+          for first-p = t then nil
+          do (unless first-p
+               (incf offset 3)
+               (incf x (funcall measure " | ")))
+             (when (>= offset prefix-length) (return))
+             (let* ((text (%bar-string (head-bar-segment-text segment)))
+                    (visible-length (min (length text) (- prefix-length offset)))
+                    (end-x (+ x (funcall measure (subseq text 0 visible-length)))))
+               (when (and (> end-x x) (head-bar-segment-click-action segment))
+                 (push (list x end-x segment) spans))
+               (incf offset (length text))
+               (setf x end-x)))
+    (nreverse spans)))
+
+(defun %head-bar-height (backend head)
+  (%head-bar-reserved-height backend head))
+
+(defun %free-head-bar (bar)
+  (when bar
+    (dolist (gcontext (list (x11-head-bar-background-gcontext bar)
+                            (x11-head-bar-foreground-gcontext bar)
+                            (x11-head-bar-inverse-foreground-gcontext bar)))
+      (when gcontext
+        (xlib:free-gcontext gcontext)))
+    (when (x11-head-bar-font bar)
+      (%free-text-font (x11-head-bar-font bar)))
+    (%free-ui-canvas (x11-head-bar-canvas bar))
+    (maphash (lambda (color pixel)
+               (declare (ignore color))
+               (xlib:free-colors (x11-head-bar-colormap bar) (list pixel)))
+             (x11-head-bar-colors bar))
+    (when (x11-head-bar-window bar)
+      (xlib:destroy-window (x11-head-bar-window bar)))))
+
+(defun %make-head-bar (backend head)
+  "Create the one override-redirect X11 window owned by HEAD's bar."
+  (let* ((screen (x11-backend-x-screen backend))
+         (height (%head-bar-height backend head))
+         (window (xlib:create-window
+                  :parent (x11-backend-root backend)
+                  :x (x11-head-x head) :y (x11-head-y head)
+                  :width (x11-head-width head) :height height
+                  :background (xlib:screen-black-pixel screen)
+                  :border-width 0
+                  :override-redirect :on
+                  :event-mask '(:exposure :button-press :pointer-motion :enter-window :leave-window)))
+         (black (xlib:screen-black-pixel screen))
+         (white (xlib:screen-white-pixel screen)))
+    (make-x11-head-bar
+     :head-id (x11-head-head-id head)
+     :window window :height height
+     :colormap (xlib:screen-default-colormap screen)
+     :background-gcontext (xlib:create-gcontext :drawable window
+                                                 :foreground black :background white)
+     :foreground-gcontext (xlib:create-gcontext :drawable window
+                                                 :foreground white :background black)
+     :inverse-foreground-gcontext (xlib:create-gcontext :drawable window
+                                                         :foreground black :background white))))
+
+(defun %configure-head-bar (backend bar head)
+  "Move and resize BAR when its physical Head rectangle changes."
+  (let ((height (%head-bar-height backend head))
+        (window (x11-head-bar-window bar)))
+    (xlib:with-state (window)
+      (setf (xlib:drawable-x window) (x11-head-x head)
+            (xlib:drawable-y window) (x11-head-y head)
+            (xlib:drawable-width window) (x11-head-width head)
+            (xlib:drawable-height window) height))
+    (setf (x11-head-bar-height bar) height)
+    bar))
+
+(defun %head-bar-for-window (backend window)
+  (let ((window-id (xlib:window-id window)))
+    (loop for head-id in (x11-backend-head-ids backend)
+          for bar = (gethash head-id (x11-backend-head-bars backend))
+          when (and bar
+                    (= window-id (xlib:window-id (x11-head-bar-window bar))))
+            return bar)))
+
+(defun %head-bar-visible-p (backend head-id)
+  "A genuine fullscreen client owns its physical Head, including the bar."
+  (null (ewmh-fullscreen-client-id-for-head backend head-id)))
+
+(declaim (ftype function backend-activity-slot))
+
+(defun %bar-presentation-label (backend head-id)
+  (let* ((world (x11-backend-world backend))
+         (presentation (current-presentation world head-id)))
+    (if (null presentation)
+        "No activity"
+        (handler-case
+            (activity-name (find-activity world (presentation-activity-id presentation)))
+          (unknown-entity () "Activity")))))
+
+(defun %bar-activity-entries (backend head-id)
+  "Slot-ordered Activity names; highlight where this Head is working.
+
+Saved Views are recallable arrangements, not nested workspace locations."
+  (let* ((world (x11-backend-world backend))
+         (p (current-presentation world head-id))
+         (active-id (and p (presentation-activity-id p))))
+    (mapcar (lambda (activity)
+              (let* ((id (activity-id activity)) (active-p (equal id active-id)))
+                (list :id id :active-p active-p
+                      :text (%single-line-text (activity-name activity)))))
+            (sort (list-activities world) #'<
+                  :key (lambda (a) (backend-activity-slot backend (activity-id a)))))))
+
+(defun %fit-bar-activities (entries maximum-width measure fit)
+  "Fit separate shaped tabs, keeping the active one and a clickable overflow.
+
+Inactive tabs fit whole; the active tab may be grapheme-truncated. When space
+is scarce, keep its nearest slot neighbors in order, with omitted tabs in the
+overflow picker. Runs are the sole source of painting and hit-test geometry."
+  (let* ((gap (max 8 (funcall measure "  ")))
+         (rows (loop for entry in entries for index from 0
+                     collect (list :entry entry :index index :text (getf entry :text)
+                                   :width (funcall measure (getf entry :text)))))
+         (total (+ (reduce #'+ rows :key (lambda (r) (getf r :width)) :initial-value 0)
+                   (* gap (max 0 (1- (length rows))))))
+         (selected rows) (overflow nil))
+    (when (> total maximum-width)
+      (let* ((anchor (or (find-if (lambda (r) (getf (getf r :entry) :active-p)) rows) (first rows)))
+             (more (funcall fit "…" maximum-width measure))
+             (more-width (funcall measure more))
+             (budget (max 0 (- maximum-width more-width gap)))
+             (text (and anchor (funcall fit (getf anchor :text) budget measure)))
+             (used (if text (funcall measure text) 0)))
+        (setf selected nil)
+        (when (plusp used)
+          (let ((fitted (copy-list anchor)))
+            (setf (getf fitted :text) text (getf fitted :width) used)
+            (push fitted selected))
+          (dolist (row (stable-sort (remove anchor (copy-list rows)) #'<
+                                   :key (lambda (r) (abs (- (getf r :index) (getf anchor :index))))))
+            (when (<= (+ used gap (getf row :width)) budget)
+              (incf used (+ gap (getf row :width)))
+              (push row selected))))
+        (setf selected (sort selected #'< :key (lambda (r) (getf r :index))))
+        (when (plusp more-width)
+          (setf overflow (list :text more :width more-width :overflow-p t)))))
+    (let ((x 0) (runs nil))
+      (dolist (row (append selected (when overflow (list overflow))))
+        (when runs (incf x gap))
+        (push (list :x x :width (getf row :width) :text (getf row :text)
+                    :entry (getf row :entry) :overflow-p (getf row :overflow-p)) runs)
+        (incf x (getf row :width)))
+      (values "" 0 x (nreverse runs)))))
+
+(defun %bar-open-activity (backend head-id activity-id)
+  "A tab click uses the same resume/no-op/lease choices as number keys."
+  (backend-select-head backend head-id)
+  (%show-navigation-result backend (%ui-request-activity-activation backend activity-id)))
+
+(defun %bar-monocle-client-count (world presentation)
+  "Count all leased tiles in monocle, including the currently visible one.
+
+Floats, explicitly hidden Activity clients, and tiles leased elsewhere are
+not part of this Head's monocle stack."
+  (let ((leased-client-ids (presentation-leased-client-ids world presentation)))
+    (count-if (lambda (placement)
+                (and (eq (placement-kind placement) :tile)
+                     (member (placement-client-id placement)
+                             leased-client-ids :test #'equal)))
+              (presentation-placements presentation))))
+
+(defun %bar-layout-token (backend head-id)
+  "Render the compact layout vocabulary used by Lime's initial bar.
+
+There is no all-floating layout today.  `><>` therefore remains reserved for
+a future explicit layout policy; individual floated clients continue to show
+the View's underlying tiled policy here."
+  (let* ((world (x11-backend-world backend))
+         (presentation (current-presentation world head-id)))
+    (if (null presentation)
+        ""
+        (case (presentation-layout-mode presentation)
+          (:master-stack "[]=")
+          (:manual "|M|")
+          (:monocle (format nil "[~D]"
+                             (%bar-monocle-client-count world presentation)))
+          (otherwise "|M|")))))
+
+(defun %bar-focused-client-id (backend head-id)
+  (or (ewmh-fullscreen-client-id-for-head backend head-id)
+      (let ((presentation (current-presentation (x11-backend-world backend)
+                                                head-id)))
+        (and presentation (presentation-focus-client-id presentation)))))
+
+(defun %bar-focused-title (backend head-id)
+  (let ((client-id (%bar-focused-client-id backend head-id)))
+    (cond
+      ((null client-id) "")
+      (t
+       (let ((info (backend-client-icccm-info backend client-id)))
+         (or (and info (%nonempty-title (icccm-client-info-title info)))
+             (and info (%nonempty-title (icccm-client-info-resource-class info)))
+             (and info (%nonempty-title (icccm-client-info-resource-name info)))
+             "Untitled window"))))))
+
+(defun %provider-segments (backend head-id)
+  "Collect valid segments while keeping one status module failure non-fatal."
+  (loop for provider in (x11-backend-head-bar-status-providers backend)
+        append
+        (handler-case
+            (let ((result (if (functionp provider)
+                              (funcall provider backend head-id)
+                              (%managed-provider-segment backend provider))))
+              (cond
+                ((null result) '())
+                ((typep result 'head-bar-segment) (list (%validate-head-bar-segment result)))
+                ((listp result)
+                 (mapcar #'%validate-head-bar-segment
+                  (remove-if-not (lambda (segment)
+                                  (typep segment 'head-bar-segment))
+                                result)))
+                (t '())))
+          (error (condition)
+            (setf (x11-backend-last-command-error backend) condition)
+            '()))))
+
+(defun %bar-status-string (segments)
+  (format nil "~{~A~^ | ~}" (mapcar #'head-bar-segment-text segments)))
+
+(defun %bar-attention-segment (backend)
+  "Global count on every Head: parked Activities must still be discoverable."
+  (let* ((style (%head-bar-style backend))
+         (count (length (backend-attention-client-ids backend))))
+    (when (and (head-bar-style-attention-indicator-p style) (plusp count))
+      (make-head-bar-segment
+       :id :attention
+       :text (format nil "~A ~D" (head-bar-style-attention-marker style) count)
+       :foreground (head-bar-style-attention-color style)
+       :click-action (lambda (clicked-backend head-id)
+                       (backend-focus-head-background clicked-backend head-id)
+                       (backend-open-attention-picker clicked-backend))))))
+
+(defun %fit-bar-status (font segments maximum-width)
+  "Shape each provider separately: RTL text must not reorder neighboring widgets."
+  (let ((runs '()) (x 0) (prefix 0) (first-p t))
+    (block fit
+      (dolist (segment segments)
+        (let ((text (%single-line-text (head-bar-segment-text segment))))
+          (when (plusp (length text))
+            (dolist (token (append (unless first-p (list (cons nil " | ")))
+                                  (list (cons segment text))))
+              (let* ((remaining (- maximum-width x))
+                     (cap (and (car token) (head-bar-segment-maximum-width (car token))))
+                     (budget (if (and (integerp cap) (plusp cap)) (min remaining cap) remaining)))
+                (multiple-value-bind (visible retained)
+                    (%fit-ui-text font (cdr token) budget)
+                  (let ((width (%text-width font visible)))
+                    (when (plusp width)
+                      (push (list :x x :text visible :width width :prefix retained
+                                  :segment (car token)) runs))
+                    (incf x width)
+                    (incf prefix retained)
+                    ;; A deliberately capped song must leave space for volume
+                    ;; and clock; exhausted whole-bar space still ends the run.
+                    (when (and (< retained (length (cdr token))) (>= budget remaining))
+                      (return-from fit nil))))))
+            (setf first-p nil)))))
+    (values "" prefix x (nreverse runs))))
+
+(defun %draw-head-bar (backend bar)
+  "Render a complete Unicode frame and derive click regions from shaped text."
+  (let* ((head-id (x11-head-bar-head-id bar))
+         (window (x11-head-bar-window bar))
+         (font (setf (x11-head-bar-font bar)
+                     (%ensure-text-font (x11-head-bar-font bar) (%configured-font backend))))
+         (measure (lambda (text) (%text-width font text)))
+         (fit (lambda (text width ignored) (declare (ignore ignored))
+                (%fit-ui-text font text width)))
+         (width (xlib:drawable-width window))
+         (height (x11-head-bar-height bar))
+         (canvas (setf (x11-head-bar-canvas bar)
+                       (%ensure-ui-canvas (x11-head-bar-canvas bar) width height)))
+         (style (%head-bar-style backend))
+         (baseline (%font-centered-baseline font height))
+         (focused-p (equal head-id (x11-backend-focused-head-id backend)))
+         ;; First claim on status space so a long song cannot hide the alert.
+         (segments (append (let ((attention (%bar-attention-segment backend)))
+                             (when attention (list attention)))
+                           (%provider-segments backend head-id)))
+         (activities (%bar-activity-entries backend head-id))
+         (layout (%bar-text-layout
+                  width (%bar-presentation-label backend head-id)
+                  (%bar-layout-token backend head-id) (%bar-focused-title backend head-id)
+                  "" measure :padding-x (head-bar-style-padding-x style) :fit fit
+                  :minimum-label-width (if activities 96 0)
+                  :label-fit (lambda (label budget ignored)
+                               (declare (ignore label ignored))
+                               (%fit-bar-activities activities budget measure fit))
+                  :status-fit (lambda (ignored budget ignored-measure)
+                                (declare (ignore ignored ignored-measure))
+                                (%fit-bar-status font segments budget))))
+         (foreground (head-bar-style-foreground style))
+         (separator (head-bar-style-separator-color style))
+         (title-left (getf layout :title-left))
+         (title-right (getf layout :title-right))
+         (regions '()))
+    (%canvas-rectangle canvas 0 0 width height (head-bar-style-background style))
+    (flet ((draw (text x color &optional (limit (funcall measure text)))
+             (%canvas-text canvas font text x 0 limit height color :baseline baseline)))
+      (draw (getf layout :logo) (getf layout :logo-x)
+            (or (head-bar-style-logo-color style) foreground))
+      (push (make-x11-head-bar-hit-region
+             :left 0 :right (getf layout :logo-width)
+             :action (lambda (clicked-backend clicked-head-id)
+                       (backend-select-head clicked-backend clicked-head-id)
+                       (backend-open-command-palette clicked-backend))) regions)
+      (dolist (run (getf layout :label-runs))
+        (let* ((entry (getf run :entry)) (id (getf entry :id))
+               (x (+ (getf layout :label-x) (getf run :x))))
+          (draw (getf run :text) x
+                (cond ((getf run :overflow-p) separator)
+                      ((getf entry :active-p) (%ui-accent-color style))
+                      (t foreground))
+                (getf run :width))
+          (push (make-x11-head-bar-hit-region
+                 :left x :right (+ x (getf run :width))
+                 :action (if (getf run :overflow-p)
+                             (lambda (b head)
+                               (backend-select-head b head)
+                               (backend-open-activity-picker b))
+                             (lambda (b head) (%bar-open-activity b head id)))) regions)))
+      (let ((token (getf layout :layout-token)) (x (getf layout :layout-x)))
+        (when (plusp (length token))
+          (draw token x foreground)
+          (push (make-x11-head-bar-hit-region
+                 :left x :right (+ x (funcall measure token))
+                 :action (lambda (clicked-backend clicked-head-id)
+                           (backend-cycle-layout clicked-backend :head-id clicked-head-id))) regions)))
+      (%canvas-rectangle canvas title-left 0 (- title-right title-left) height
+                         (if focused-p (head-bar-style-focused-background style)
+                             (head-bar-style-unfocused-background style)))
+      (when (and (> title-right title-left) (head-bar-style-title-edge-color style))
+        (dolist (x (remove-duplicates (list title-left (1- title-right))))
+          (%canvas-rectangle canvas x 0 1 height (head-bar-style-title-edge-color style))))
+      (draw (getf layout :title) (getf layout :title-x)
+            (if focused-p (head-bar-style-focused-foreground style)
+                (head-bar-style-unfocused-foreground style))
+            (getf layout :title-width))
+      (dolist (span (getf layout :separators)) (draw (cdr span) (car span) separator))
+      (dolist (run (getf layout :status-runs))
+        (let* ((text (getf run :text))
+               (x (+ (getf layout :status-x) (getf run :x)))
+               (segment (getf run :segment)))
+          (%canvas-text canvas font text x 0 (getf run :width) height
+                        (if segment (or (head-bar-segment-foreground segment) foreground) separator)
+                        :baseline baseline
+                        :prefix-length (if segment
+                                           (min (getf run :prefix) (head-bar-segment-prefix-length segment))
+                                           0)
+                        :prefix-color (and segment (head-bar-segment-prefix-foreground segment)))
+          (when (and segment (head-bar-segment-click-action segment))
+            (dolist (range (%text-prefix-ranges font text (getf run :prefix)))
+              (when (> (cdr range) (car range))
+                (push (make-x11-head-bar-hit-region
+                       :left (+ x (car range)) :right (+ x (cdr range))
+                       :action (head-bar-segment-click-action segment)) regions)))))))
+    (%prune-head-bar-colors bar style)
+    (%present-ui-canvas backend canvas window (x11-head-bar-foreground-gcontext bar))
+    (setf (x11-head-bar-hit-regions bar) (nreverse regions))
+    (xlib:map-window window)
+    (setf (xlib:window-priority window) :above)
+    ;; Status/geometry changes can alter clickability without pointer motion.
+    (let ((point (%ui-window-pointer-position backend window)))
+      (%update-head-bar-pointer backend bar
+                                (and point (%head-bar-hit-at bar (car point) (cdr point)))))
+    bar))
+
+(defun render-head-bars (backend)
+  "Redraw and raise every visible Head bar after a model or focus change."
+  (when (x11-backend-display backend)
+    (dolist (head-id (x11-backend-head-ids backend))
+      (let ((bar (gethash head-id (x11-backend-head-bars backend))))
+        (when bar
+          (if (%head-bar-visible-p backend head-id)
+              (%draw-head-bar backend bar)
+              (xlib:unmap-window (x11-head-bar-window bar))))))
+    (xlib:display-force-output (x11-backend-display backend)))
+  backend)
+
+(defun reconcile-head-bars (backend)
+  "Make the adapter-owned bar set match the currently configured Head set."
+  (let ((bars (x11-backend-head-bars backend))
+        (head-ids (x11-backend-head-ids backend)))
+    (maphash (lambda (head-id bar)
+               (unless (member head-id head-ids :test #'equal)
+                 (%free-head-bar bar)
+                 (remhash head-id bars)))
+             bars)
+    (dolist (head-id head-ids)
+      (let* ((head (%head-for-id backend head-id))
+             (height (%head-bar-height backend head))
+             (existing (gethash head-id bars)))
+        (cond
+          ((zerop height)
+           (when existing
+             (%free-head-bar existing)
+             (remhash head-id bars)))
+          (existing
+           (%configure-head-bar backend existing head))
+          (t
+           (setf (gethash head-id bars) (%make-head-bar backend head)))))))
+  (render-head-bars backend))
+
+(defun initialize-head-bars (backend)
+  "Create Lime's persistent bar windows for the backend's initial Heads."
+  (reconcile-head-bars backend))
+
+(defun shutdown-head-bars (backend)
+  "Free every adapter-owned Head bar while the CLX display is still open."
+  (maphash (lambda (head-id bar)
+             (declare (ignore head-id))
+             (%free-head-bar bar))
+           (x11-backend-head-bars backend))
+  (clrhash (x11-backend-head-bars backend))
+  backend)
+
+(defun backend-set-head-bar-height (backend height)
+  "Set a non-negative top-bar reservation and immediately reflow clients."
+  (unless (and (integerp height) (not (minusp height)))
+    (error 'invalid-transition
+           :description "A Head bar height must be a non-negative integer."))
+  (setf (x11-backend-head-bar-height backend) height)
+  (reconcile-head-bars backend)
+  (apply-active-presentation backend)
+  backend)
+
+(defun backend-set-head-bar-status-providers (backend providers)
+  "Install right-side status PROVIDERS and redraw without changing model state.
+
+Providers may be fast functions of (BACKEND HEAD-ID), returning segments,
+or managed STATUS-PROVIDER objects whose I/O runs outside the X event thread."
+  (%validate-status-providers providers)
+  (%reconcile-status-providers backend providers)
+  (setf (x11-backend-head-bar-status-providers backend) (copy-list providers))
+  (render-head-bars backend))
+
+(defun %handle-head-bar-exposure (backend window count)
+  "Redraw an exposed bar and return true exactly when WINDOW belongs to Lime."
+  (let ((bar (%head-bar-for-window backend window)))
+    (when (and bar (zerop count))
+      (when (%head-bar-visible-p backend (x11-head-bar-head-id bar))
+        (%draw-head-bar backend bar))
+      (xlib:display-force-output (x11-backend-display backend)))
+    (not (null bar))))
+
+(defun %head-bar-hit-at (bar x y)
+  "The same measured regions drive both the hand cursor and click dispatch."
+  (when (<= 0 y (1- (x11-head-bar-height bar)))
+    (find-if (lambda (region)
+               (and (x11-head-bar-hit-region-action region)
+                    (<= (x11-head-bar-hit-region-left region) x)
+                    (< x (x11-head-bar-hit-region-right region))))
+             (x11-head-bar-hit-regions bar))))
+
+(defun %update-head-bar-pointer (backend bar hit)
+  (setf (x11-head-bar-pointer-hand-p bar)
+        (%set-ui-pointer backend (x11-head-bar-window bar) hit (x11-head-bar-pointer-hand-p bar))))
+
+(defun %handle-head-bar-motion (backend window root-x root-y)
+  (let ((bar (%head-bar-for-window backend window)))
+    (when bar
+      (%update-head-bar-pointer backend bar
+                                (%head-bar-hit-at bar (- root-x (xlib:drawable-x window))
+                                                      (- root-y (xlib:drawable-y window))))
+      t)))
+
+(defun %handle-head-bar-leave (backend window)
+  (let ((bar (%head-bar-for-window backend window)))
+    (when bar (%update-head-bar-pointer backend bar nil))))
+
+(defun %handle-head-bar-button-press (backend window root-x root-y button state time)
+  "Route a Head-bar click without allowing the pointer layer to see it."
+  (declare (ignore state time))
+  (let ((bar (%head-bar-for-window backend window)))
+    (when bar
+      (let* ((head-id (x11-head-bar-head-id bar))
+             (head (%head-for-id backend head-id))
+             (local-x (- root-x (x11-head-x head))))
+        ;; A bar click makes its Head the command target even if it lands on
+        ;; inert text.  This mirrors a background click without changing View
+        ;; contents or stealing the saved client focus target.
+        (when (= button 1)
+          (backend-focus-head-background backend head-id)
+          (let ((region (%head-bar-hit-at bar local-x (- root-y (x11-head-y head)))))
+            (when region
+              (funcall (x11-head-bar-hit-region-action region) backend head-id))))
+        t))))

src/x11/config-package.lisp

@@ -0,0 +1,13 @@
+(defpackage #:lime.config
+  (:use #:cl)
+  (:documentation
+   "User-facing Common Lisp configuration for the Lime X11 adapter.")
+  (:export
+   #:defconfiguration
+   #:start-lime
+   #:load-configuration
+   #:apply-configuration
+   #:reload-configuration
+   #:run-command
+   #:list-commands
+   #:find-command))

src/x11/config.lisp

@@ -0,0 +1,891 @@
+(in-package #:lime.x11)
+
+;;;; User configuration: a small declarative layer over public commands
+;;;
+;;; Configuration stays outside LIME.CORE.  It is adapter policy which says
+;;; which input invokes a command, how a freshly mapped X11 client is styled,
+;;; and which optional bar providers should run.  Activities, Views, leases,
+;;; and saved layouts are deliberately never serialized into or reconstructed
+;;; from a configuration file.
+
+(defstruct lime-command
+  "One user-named imperative command shared by bindings and the palette.
+
+ACTION is a function of one X11-BACKEND.  KEY is optional and only controls
+the command's entry under the palette's `User` which-key branch; it does not
+create a passive X11 grab by itself."
+  id
+  label
+  description
+  category
+  key
+  action)
+
+(defstruct configuration-binding
+  "A declarative passive-key binding to a LIME-COMMAND id."
+  key
+  modifiers
+  command-id
+  description)
+
+(defstruct window-rule
+  "An ordered, initial-placement rule for ordinary newly managed clients.
+
+RESOURCE-NAME, RESOURCE-CLASS, and TITLE are NIL (wildcard), a string
+(case-insensitive exact match), or a predicate of one actual string-or-NIL.
+PREDICATE, when supplied, receives BACKEND, CLIENT-ID, and ICCCM-CLIENT-INFO.
+The first matching rule wins.  The intentionally small initial action set is
+FLOAT-P and CENTER-P: it never mounts a View, changes an Activity, or takes a
+lease as an incidental result of a WM_CLASS match."
+  id
+  resource-name
+  resource-class
+  title
+  predicate
+  (float-p nil)
+  (center-p nil))
+
+(defstruct layout-client-flow-policy
+  "Per-layout placement and removal policy for ordinary tiled clients.
+
+LAYOUT-MODE is one of Lime's built-in layout modes.  A configuration may
+override only the modes it cares about; its ordinary global client-flow
+settings remain the fallback for the others."
+  layout-mode
+  (new-tiled-client-position :back)
+  (close-focus-direction :previous))
+
+(defstruct lime-configuration
+  "A fully evaluated user configuration ready to install on a backend."
+  (default-keybindings-p nil)
+  (default-modifiers '(:mod-4))
+  (default-layout :master-stack)
+  ;; Client-flow policy is adapter configuration, not a property of an
+  ;; Activity or saved View.  The defaults deliberately match Lime's starter
+  ;; workflow: new clients are focused, append at the visual bottom of a
+  ;; master/stack layout, and focus moves back toward master after removal.
+  (new-client-focus-p t)
+  (new-tiled-client-position :back)
+  (close-focus-direction :previous)
+  ;; Monocle's meaningful order is its focus cycle rather than its geometry:
+  ;; a new client becomes the visible one and closing it advances to the next
+  ;; older client.  Further entries selectively override this built-in policy.
+  (layout-client-flow-policies
+    (list (make-layout-client-flow-policy
+           :layout-mode :monocle
+           :new-tiled-client-position :front
+           :close-focus-direction :next)))
+  (commands '())
+  (bindings '())
+  (rules '())
+  (appearance (make-window-appearance))
+  (bar-style (make-head-bar-style))
+  (font (make-ui-font-style))
+  (cursor (make-ui-cursor-style))
+  bar-height
+  (bar-height-supplied-p nil)
+  status-providers
+  (status-providers-supplied-p nil)
+  (startup-hooks '()))
+
+(defvar *lime-configuration-definitions* (make-hash-table :test #'eq)
+  "Configuration name symbol -> latest object defined by DEFCONFIGURATION.")
+
+(defvar *lime-configuration-load-names* nil
+  "Dynamically collects definitions evaluated by LOAD-LIME-CONFIGURATION.")
+
+(defun register-lime-configuration (name configuration)
+  "Register NAME as CONFIGURATION and return CONFIGURATION.
+
+DEFCONFIGURATION calls this while a user file is loaded.  It is public mostly
+for people constructing a configuration entirely from ordinary Lisp instead
+of the small macro surface."
+  (unless (symbolp name)
+    (error 'invalid-transition
+           :description "A Lime configuration name must be a symbol."))
+  (unless (typep configuration 'lime-configuration)
+    (error 'invalid-transition
+           :description "A registered Lime configuration must be a LIME-CONFIGURATION."))
+  (setf (gethash name *lime-configuration-definitions*) configuration)
+  (when (boundp '*lime-configuration-load-names*)
+    (pushnew name *lime-configuration-load-names* :test #'eq))
+  configuration)
+
+(defun find-lime-configuration (name)
+  "Return the configuration registered as NAME, or signal a useful error."
+  (or (gethash name *lime-configuration-definitions*)
+      (error 'invalid-transition
+             :description (format nil "No Lime configuration named ~S is loaded." name))))
+
+(defun %configuration-name-from-load (names requested-name)
+  (cond
+    (requested-name
+     (unless (member requested-name names :test #'eq)
+       (error 'invalid-transition
+              :description
+              (format nil "Configuration file did not define the requested ~S configuration."
+                      requested-name)))
+     requested-name)
+    ((null names)
+     (error 'invalid-transition
+            :description "The configuration file did not evaluate DEFCONFIGURATION."))
+    ((null (rest names))
+     (first names))
+    (t
+     (error 'invalid-transition
+            :description
+            (format nil "The configuration file defined ~{~S~^, ~}; choose one with :NAME."
+                    names)))))
+
+(defun load-lime-configuration (path &key name)
+  "Load PATH and return its one newly defined LIME-CONFIGURATION.
+
+When a file deliberately defines several configurations, NAME selects one of
+the symbols it defined during this load.  The second return value is that
+symbol, retained by a backend so `reload-configuration` can faithfully reload
+the same choice later.  Loading evaluates normal Common Lisp; keep the file's
+top-level effects limited to configuration definitions and helper functions."
+  (let ((*lime-configuration-load-names* '()))
+    (load path)
+    (let* ((names (nreverse *lime-configuration-load-names*))
+           (selected-name (%configuration-name-from-load names name)))
+      (values (find-lime-configuration selected-name) selected-name))))
+
+(defun %configuration-command-id-valid-p (id)
+  (or (symbolp id) (stringp id) (integerp id)))
+
+(defun %configuration-modifiers-valid-p (modifiers)
+  (or (integerp modifiers) (listp modifiers)))
+
+(defun %configuration-duplicate-p (items key-function &key (test #'equal))
+  ;; The configuration lists are intentionally tiny, and MEMBER lets the
+  ;; which-key alphabet use CHAR-EQUAL (which MAKE-HASH-TABLE cannot accept
+  ;; as an equivalence relation) without a separate normalization path.
+  (let ((seen '()))
+    (loop for item in items
+          for key = (funcall key-function item)
+          thereis (if (member key seen :test test)
+                      t
+                      (progn (push key seen) nil)))))
+
+(defun %validate-window-rule (rule)
+  (unless (typep rule 'window-rule)
+    (error 'invalid-transition
+           :description "Configuration rules must be WINDOW-RULE objects."))
+  (dolist (value (list (window-rule-resource-name rule)
+                       (window-rule-resource-class rule)
+                       (window-rule-title rule)))
+    (unless (or (null value) (stringp value) (functionp value))
+      (error 'invalid-transition
+             :description "A window-rule matcher must be NIL, a string, or a function.")))
+  (when (and (window-rule-predicate rule)
+             (not (functionp (window-rule-predicate rule))))
+    (error 'invalid-transition
+           :description "A window-rule :PREDICATE must be a function."))
+  (when (and (window-rule-center-p rule) (not (window-rule-float-p rule)))
+    (error 'invalid-transition
+           :description "A centered window rule must also specify :FLOAT T."))
+  rule)
+
+(defun %validate-lime-configuration (configuration)
+  "Check all reloadable policy before changing any installed backend state."
+  (unless (typep configuration 'lime-configuration)
+    (error 'invalid-transition
+           :description "Expected a LIME-CONFIGURATION."))
+  (unless (%configuration-modifiers-valid-p
+           (lime-configuration-default-modifiers configuration))
+    (error 'invalid-transition
+           :description "Configuration default modifiers must be a list or integer mask."))
+  (unless (member (lime-configuration-default-layout configuration)
+                  '(:manual :master-stack :monocle))
+    (error 'invalid-transition
+           :description "Configuration :DEFAULT-LAYOUT must be :MANUAL, :MASTER-STACK, or :MONOCLE."))
+  (unless (member (lime-configuration-new-client-focus-p configuration) '(t nil))
+    (error 'invalid-transition
+           :description "Configuration :NEW-CLIENT-FOCUS must be T or NIL."))
+  (unless (member (lime-configuration-new-tiled-client-position configuration)
+                  '(:front :back))
+    (error 'invalid-transition
+           :description "Configuration :NEW-TILED-CLIENT-POSITION must be :FRONT or :BACK."))
+  (unless (member (lime-configuration-close-focus-direction configuration)
+                  '(:previous :next))
+    (error 'invalid-transition
+           :description "Configuration :CLOSE-FOCUS-DIRECTION must be :PREVIOUS or :NEXT."))
+  (let ((policies (lime-configuration-layout-client-flow-policies configuration)))
+    (unless (and (listp policies)
+                 (every (lambda (policy)
+                          (and (typep policy 'layout-client-flow-policy)
+                               (member (layout-client-flow-policy-layout-mode policy)
+                                       '(:manual :master-stack :monocle))
+                               (member (layout-client-flow-policy-new-tiled-client-position policy)
+                                       '(:front :back))
+                               (member (layout-client-flow-policy-close-focus-direction policy)
+                                       '(:previous :next))))
+                        policies))
+      (error 'invalid-transition
+             :description "Each layout client-flow policy needs a known layout mode, :FRONT/:BACK insertion, and :PREVIOUS/:NEXT close direction."))
+    (when (%configuration-duplicate-p policies
+                                      #'layout-client-flow-policy-layout-mode)
+      (error 'invalid-transition
+             :description "A configuration may define at most one client-flow policy per layout mode.")))
+  (let ((commands (lime-configuration-commands configuration))
+        (bindings (lime-configuration-bindings configuration)))
+    (unless (every (lambda (command)
+                     (and (typep command 'lime-command)
+                          (%configuration-command-id-valid-p (lime-command-id command))
+                          (stringp (lime-command-label command))
+                          (functionp (lime-command-action command))
+                          (or (null (lime-command-key command))
+                              (characterp (lime-command-key command)))))
+                   commands)
+      (error 'invalid-transition
+             :description "Every configuration command needs an id, string label, function action, and optional character key."))
+    (when (%configuration-duplicate-p commands #'lime-command-id)
+      (error 'invalid-transition
+             :description "Configuration command ids must be unique."))
+    (when (%configuration-duplicate-p (remove nil (mapcar #'lime-command-key commands)) #'identity
+                                      :test #'char-equal)
+      (error 'invalid-transition
+             :description "Configuration which-key command letters must be unique."))
+    (unless (every (lambda (binding)
+                     (and (typep binding 'configuration-binding)
+                          (or (characterp (configuration-binding-key binding))
+                              (and (integerp (configuration-binding-key binding))
+                                   (not (minusp (configuration-binding-key binding)))))
+                          (%configuration-modifiers-valid-p
+                           (configuration-binding-modifiers binding))
+                          (find (configuration-binding-command-id binding) commands
+                                :key #'lime-command-id :test #'equal)))
+                   bindings)
+      (error 'invalid-transition
+             :description "Each configuration binding needs a key, valid modifiers, and a configured command id."))
+    (when (%configuration-duplicate-p
+           bindings
+           (lambda (binding)
+             (list (configuration-binding-key binding)
+                   (configuration-binding-modifiers binding))))
+      (error 'invalid-transition
+             :description "Configuration key/modifier pairs must be unique.")))
+  (dolist (rule (lime-configuration-rules configuration))
+    (%validate-window-rule rule))
+  (%validate-window-appearance (lime-configuration-appearance configuration))
+  (%validate-head-bar-style (lime-configuration-bar-style configuration))
+  (%validate-ui-font-style (lime-configuration-font configuration))
+  (%validate-ui-cursor-style (lime-configuration-cursor configuration))
+  (when (lime-configuration-bar-height-supplied-p configuration)
+    (unless (and (integerp (lime-configuration-bar-height configuration))
+                 (not (minusp (lime-configuration-bar-height configuration))))
+      (error 'invalid-transition
+             :description "A configured bar height must be a non-negative integer.")))
+  (when (lime-configuration-status-providers-supplied-p configuration)
+    (%validate-status-providers (lime-configuration-status-providers configuration)))
+  (unless (every #'functionp (lime-configuration-startup-hooks configuration))
+    (error 'invalid-transition
+           :description "Configuration startup hooks must be functions."))
+  configuration)
+
+(defun configured-new-client-focus-p (backend)
+  "Return BACKEND's ordinary newly-managed-client focus policy."
+  (let ((configuration (x11-backend-configuration backend)))
+    (if configuration
+        (lime-configuration-new-client-focus-p configuration)
+        t)))
+
+(defun configured-default-layout (backend)
+  "Initial layout for a new Head-local draft; never reapplied on resume/reload."
+  (let ((configuration (x11-backend-configuration backend)))
+    (if configuration
+        (lime-configuration-default-layout configuration)
+        (x11-backend-default-layout backend))))
+
+(defun %configured-layout-client-flow-policy (backend layout-mode)
+  "Return the optional explicit policy for LAYOUT-MODE on BACKEND."
+  (let ((configuration (x11-backend-configuration backend)))
+    (and configuration
+         (find layout-mode
+               (lime-configuration-layout-client-flow-policies configuration)
+               :key #'layout-client-flow-policy-layout-mode))))
+
+(defun configured-new-tiled-client-position (backend layout-mode)
+  "Return where new tiled clients enter LAYOUT-MODE's placement ordering."
+  (let ((policy (%configured-layout-client-flow-policy backend layout-mode))
+        (configuration (x11-backend-configuration backend)))
+    (cond
+      (policy (layout-client-flow-policy-new-tiled-client-position policy))
+      ((eq layout-mode :monocle) :front)
+      (configuration (lime-configuration-new-tiled-client-position configuration))
+      (t :back))))
+
+(defun configured-close-focus-direction (backend layout-mode)
+  "Return the removal focus direction preferred by LAYOUT-MODE."
+  (let ((policy (%configured-layout-client-flow-policy backend layout-mode))
+        (configuration (x11-backend-configuration backend)))
+    (cond
+      (policy (layout-client-flow-policy-close-focus-direction policy))
+      ((eq layout-mode :monocle) :next)
+      (configuration (lime-configuration-close-focus-direction configuration))
+      (t :previous))))
+
+(defun list-configured-commands (backend)
+  "Return BACKEND's user-defined commands in configuration order."
+  (copy-list
+   (and (x11-backend-configuration backend)
+        (lime-configuration-commands (x11-backend-configuration backend)))))
+
+(defun find-configured-command (backend command-id)
+  "Find a configured command by id, without inventing a fallback behavior."
+  (or (find command-id (list-configured-commands backend)
+            :key #'lime-command-id :test #'equal)
+      (error 'invalid-transition
+             :description (format nil "No configured command named ~S exists." command-id))))
+
+(defun run-configured-command (backend command-id)
+  "Run COMMAND-ID against BACKEND and return its ordinary Lisp result."
+  (funcall (lime-command-action (find-configured-command backend command-id))
+           backend))
+
+(defun %restore-keybindings (backend bindings)
+  "Restore a captured binding list after a failed configuration install."
+  (dolist (binding bindings)
+    (bind-key backend (keybinding-key binding) (keybinding-modifiers binding)
+              (keybinding-handler binding)
+              :description (keybinding-description binding))))
+
+(defun %install-configuration-bindings (backend configuration)
+  (clear-keybindings backend)
+  (when (lime-configuration-default-keybindings-p configuration)
+    (install-default-keybindings
+     backend :modifiers (lime-configuration-default-modifiers configuration)))
+  (dolist (binding (lime-configuration-bindings configuration))
+    (let ((command-id (configuration-binding-command-id binding)))
+      (bind-key
+       backend
+       (configuration-binding-key binding)
+       (configuration-binding-modifiers binding)
+       (lambda (bound-backend)
+         (run-configured-command bound-backend command-id))
+       :description
+       (or (configuration-binding-description binding)
+           (lime-command-description
+            (find-configured-command backend command-id)))))))
+
+(defun apply-lime-configuration (backend configuration
+                                 &key source name (run-startup-hooks-p nil))
+  "Install CONFIGURATION while preserving the running Lime world.
+
+All type, rule, command, and binding-reference checks happen before touching
+the X server.  A later passive-grab/render error restores the previous binding
+set, appearance, and bar settings before the error is re-signalled. Reloading normally
+leaves startup hooks alone; START-LIME opts into them once after initial
+installation so a reload can never unexpectedly launch another program."
+  (%validate-lime-configuration configuration)
+  (let ((old-configuration (x11-backend-configuration backend))
+        (old-source (x11-backend-configuration-source backend))
+        (old-name (x11-backend-configuration-name backend))
+        (old-appearance (x11-backend-window-appearance backend))
+        (old-bindings (list-keybindings backend))
+        (old-bar-height (x11-backend-head-bar-height backend))
+        (old-cursors (x11-backend-cursor-set backend))
+        (session-settings-touched-p nil)
+        (new-cursors nil)
+        (old-status-providers
+          (copy-list (x11-backend-head-bar-status-providers backend))))
+    (handler-case
+        (progn
+          ;; Keep the old XIDs alive until every other config operation commits.
+          (setf new-cursors (%prepare-cursor-set backend (lime-configuration-cursor configuration)))
+          (%install-cursor-set backend new-cursors)
+          ;; Give bound handlers the complete new command registry before
+          ;; they can ever be dispatched by X after the next output flush.
+          (setf (x11-backend-configuration backend) configuration
+                (x11-backend-configuration-source backend) source
+                (x11-backend-configuration-name backend) name
+                (x11-backend-window-appearance backend)
+                (lime-configuration-appearance configuration))
+          ;; Resolve both colors before touching window geometry. Allocation
+          ;; errors still take the same configuration rollback path.
+          (%border-pixel backend (window-appearance-focused-border
+                                 (lime-configuration-appearance configuration)))
+          (%border-pixel backend (window-appearance-unfocused-border
+                                 (lime-configuration-appearance configuration)))
+          (%install-configuration-bindings backend configuration)
+          (when (lime-configuration-bar-height-supplied-p configuration)
+            (backend-set-head-bar-height backend
+                                         (lime-configuration-bar-height configuration)))
+          (when (lime-configuration-status-providers-supplied-p configuration)
+            (backend-set-head-bar-status-providers
+             backend (lime-configuration-status-providers configuration)))
+          (apply-active-presentation backend)
+          (%render-command-palette backend)
+          ;; Unlike ordinary frames, installation needs a server roundtrip:
+          ;; catch asynchronous grab/configure errors inside this rollback.
+          (xlib:display-finish-output (x11-backend-display backend))
+          (setf session-settings-touched-p t)
+          (%apply-cursor-session-settings backend (lime-configuration-cursor configuration))
+          (when run-startup-hooks-p
+            (dolist (hook (lime-configuration-startup-hooks configuration))
+              (funcall hook backend)))
+          (%prune-border-colors backend)
+          (%free-cursor-set old-cursors)
+          configuration)
+      (error (condition)
+        ;; This path is specifically about reconfiguration plumbing, never
+        ;; core world state.  Activities, Presentations, Views, and leases
+        ;; were untouched and thus need no rollback.
+        (ignore-errors (clear-keybindings backend))
+        (ignore-errors (%restore-keybindings backend old-bindings))
+        (setf (x11-backend-configuration backend) old-configuration
+              (x11-backend-configuration-source backend) old-source
+              (x11-backend-configuration-name backend) old-name
+              (x11-backend-window-appearance backend) old-appearance)
+        (ignore-errors (%install-cursor-set backend old-cursors))
+        (when session-settings-touched-p
+          (ignore-errors
+            (%apply-cursor-session-settings
+             backend (if old-configuration (lime-configuration-cursor old-configuration)
+                         (make-ui-cursor-style)))))
+        (%free-cursor-set new-cursors)
+        (ignore-errors (backend-set-head-bar-height backend old-bar-height))
+        (ignore-errors (backend-set-head-bar-status-providers backend old-status-providers))
+        (ignore-errors (apply-active-presentation backend))
+        (ignore-errors (%render-command-palette backend))
+        (ignore-errors (xlib:display-finish-output (x11-backend-display backend)))
+        (ignore-errors (%prune-border-colors backend))
+        (error condition)))))
+
+(defun configure-backend-from-file (backend path &key name (run-startup-hooks-p nil))
+  "Load PATH then install its selected configuration on BACKEND."
+  (multiple-value-bind (configuration selected-name)
+      (load-lime-configuration path :name name)
+    (apply-lime-configuration backend configuration
+                              :source (namestring (truename path))
+                              :name selected-name
+                              :run-startup-hooks-p run-startup-hooks-p)))
+
+(defun reload-backend-configuration (backend)
+  "Reload BACKEND's original configuration file without rerunning startup hooks."
+  (let ((source (x11-backend-configuration-source backend)))
+    (unless source
+      (error 'invalid-transition
+             :description "This backend was not started from a configuration file."))
+    (configure-backend-from-file backend source
+                                 :name (x11-backend-configuration-name backend))))
+
+(defun %configuration-argument-plist-without (arguments removed-keys)
+  (loop for (key value) on arguments by #'cddr
+        unless (member key removed-keys)
+          append (list key value)))
+
+(defun start-lime (&rest start-arguments
+                   &key config-file configuration-name &allow-other-keys)
+  "Start Lime and, when CONFIG-FILE is given, install its user configuration.
+
+CONFIG-FILE configurations replace the starter keymap as one unit; request it
+again from `(:OPTIONS :DEFAULT-KEYBINDINGS T)` when desired.  With no config
+file this simply forwards to START-BACKEND and retains its normal defaults.
+The file's DEFAULT-LAYOUT takes precedence over the startup keyword."
+  (if (null config-file)
+      (apply #'start-backend
+             (%configuration-argument-plist-without
+              start-arguments '(:config-file :configuration-name)))
+      (multiple-value-bind (configuration selected-name)
+          (load-lime-configuration config-file :name configuration-name)
+        ;; Validate before claiming X or creating bootstrap drafts. The rest of
+        ;; the configuration is installed once the backend resources exist.
+        (%validate-lime-configuration configuration)
+        (let ((backend
+                (apply #'start-backend
+                       (append
+                        (%configuration-argument-plist-without
+                         start-arguments
+                         '(:config-file :configuration-name
+                           :install-default-keybindings-p :default-layout))
+                        (list :install-default-keybindings-p nil
+                              :default-layout
+                              (lime-configuration-default-layout configuration))))))
+          (handler-case
+              (progn
+                (apply-lime-configuration backend configuration
+                                          :source (namestring (truename config-file))
+                                          :name selected-name
+                                          :run-startup-hooks-p t)
+                backend)
+            (error (condition)
+              (stop-backend backend :save-session-p nil)
+              (error condition)))))))
+
+(defun %rule-text-matches-p (expected actual)
+  (cond
+    ((null expected) t)
+    ((stringp expected) (and actual (string-equal expected actual)))
+    ((functionp expected) (not (null (funcall expected actual))))
+    (t nil)))
+
+(defun %matching-window-rule (backend client-id info)
+  (let ((configuration (x11-backend-configuration backend)))
+    (when configuration
+      (find-if
+       (lambda (rule)
+         (and (%rule-text-matches-p (window-rule-resource-name rule)
+                                    (icccm-client-info-resource-name info))
+              (%rule-text-matches-p (window-rule-resource-class rule)
+                                    (icccm-client-info-resource-class info))
+              (%rule-text-matches-p (window-rule-title rule)
+                                    (icccm-client-info-title info))
+              (or (null (window-rule-predicate rule))
+                  (funcall (window-rule-predicate rule) backend client-id info))))
+       (lime-configuration-rules configuration)))))
+
+(defun apply-configured-window-rules (backend client-id window decision)
+  "Return DECISION styled by the first matching ordinary-client window rule.
+
+Rules are evaluated after ICCCM facts have been cached but before the new
+client joins any Presentation.  They do not run for transients (whose parent
+placement is mandatory) or dialog-like EWMH clients, and they do not route
+between Activities or Heads. A matching non-floating rule overrides the
+ordinary fixed-size floating default."
+  (let* ((info (backend-client-icccm-info backend client-id))
+         (rule (and info (%matching-window-rule backend client-id info))))
+    (when rule
+      (if (window-rule-float-p rule)
+          (let ((head (%head-for-id backend
+                                    (x11-placement-decision-head-id decision))))
+            (setf (x11-placement-decision-kind decision) :float
+                  (x11-placement-decision-data decision)
+                  (if (window-rule-center-p rule)
+                      (%centered-floating-data-for-window backend client-id window head)
+                      (%floating-data-for-window backend client-id window head nil))))
+          (setf (x11-placement-decision-kind decision) :tile
+                (x11-placement-decision-data decision) nil)))
+    decision))
+
+(defun configuration-command-candidates (backend)
+  "Make direct-search candidates for every first-class configured command."
+  (mapcar
+   (lambda (command)
+     (let ((command-id (lime-command-id command)))
+       (make-ui-candidate
+        :id (list :configured-command command-id)
+        :label (format nil "Command: ~A" (lime-command-label command))
+        :detail (or (lime-command-description command)
+                    (format nil "~A command" (or (lime-command-category command)
+                                                   "User")))
+        :key-hint "Enter"
+        :action
+        (lambda ()
+          (let ((result (run-configured-command backend command-id)))
+            (if (typep result 'ui-result)
+                result
+                (ui-close-result
+                 (or (lime-command-description command)
+                     (format nil "Ran ~A." (lime-command-label command))))))))))
+   (list-configured-commands backend)))
+
+(defun configuration-command-key-nodes (backend)
+  "Return optional `User` which-key children declared by configuration."
+  (loop for command in (list-configured-commands backend)
+        when (lime-command-key command)
+          collect
+          (let ((command-id (lime-command-id command)))
+            (make-ui-key-node
+             :id (list :configured-command command-id)
+             :key (lime-command-key command)
+             :label (lime-command-label command)
+             :detail (or (lime-command-description command)
+                         (format nil "~A command" (or (lime-command-category command)
+                                                        "User")))
+             :action
+             (lambda ()
+               (let ((result (run-configured-command backend command-id)))
+                 (if (typep result 'ui-result)
+                     result
+                     (ui-close-result
+                      (or (lime-command-description command)
+                          (format nil "Ran ~A." (lime-command-label command)))))))))))
+
+(in-package #:lime.config)
+
+;;;; Small, readable source-file DSL
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun %configuration-option (options key &optional default)
+    (if (member key options)
+        (getf options key)
+        default))
+
+  (defun %require-configuration-options (options allowed context)
+    (unless (evenp (length options))
+      (error "~A needs keyword/value pairs, got ~S." context options))
+    (loop for key in options by #'cddr
+          do (unless (member key allowed)
+               (error "~A does not understand ~S." context key)))))
+
+(defun %configuration-command-label (id)
+  (etypecase id
+    (symbol (string-capitalize (symbol-name id)))
+    (string id)
+    (integer (princ-to-string id))))
+
+(defmacro defconfiguration (name &body clauses)
+  "Define and register one reloadable Lime user configuration.
+
+The compact clauses are deliberately data-first Common Lisp:
+
+  (:OPTIONS :DEFAULT-KEYBINDINGS T :DEFAULT-MODIFIERS '(:MOD-4)
+            :DEFAULT-LAYOUT :MASTER-STACK
+            :NEW-CLIENT-FOCUS T :NEW-TILED-CLIENT-POSITION :BACK
+            :CLOSE-FOCUS-DIRECTION :PREVIOUS)
+  (:LAYOUT-FLOW :MONOCLE :NEW-TILED-CLIENT-POSITION :FRONT
+                :CLOSE-FOCUS-DIRECTION :NEXT)
+  (:COMMAND terminal :LABEL 'Terminal' :ACTION (lambda (backend) ...))
+  (:BIND #\Return terminal :MODIFIERS '(:MOD-4))
+  (:RULE :CLASS 'mpv' :FLOAT T :CENTER T)
+  (:FONT :FAMILY 'monospace' :SIZE 14 :WEIGHT :NORMAL)
+  (:BAR :HEIGHT 22 :STATUS-PROVIDERS (list #'my-status))
+  (:APPEARANCE :BORDER-WIDTH 3 :INNER-GAP 5 :OUTER-GAP 5)
+  (:STARTUP (lambda (backend) ...))
+
+Commands become searchable palette entries automatically.  Give a command
+`:KEY #\t` to also place it under the palette's `User` which-key branch;
+bind it separately when it needs a physical X key."
+  (unless (symbolp name)
+    (error "DEFCONFIGURATION needs a symbol name, got ~S." name))
+  (let ((options '())
+        (layout-flow-options '())
+        (commands '())
+        (bindings '())
+        (rules '())
+        (bar-options nil)
+        (font-options nil)
+        (font-supplied-p nil)
+        (cursor-options nil)
+        (cursor-supplied-p nil)
+        (appearance-options nil)
+        (appearance-supplied-p nil)
+        (startup-hooks '())
+        (rule-number 0))
+    (dolist (clause clauses)
+      (unless (consp clause)
+        (error "A configuration clause must be a list, got ~S." clause))
+      (case (first clause)
+        (:options
+         (when options
+           (error "DEFCONFIGURATION accepts only one :OPTIONS clause."))
+         (setf options (rest clause))
+         (%require-configuration-options
+          options '(:default-keybindings :default-modifiers :default-layout
+                    :new-client-focus :new-tiled-client-position
+                    :close-focus-direction)
+          ":OPTIONS"))
+        (:layout-flow
+         (unless (second clause)
+           (error ":LAYOUT-FLOW needs a layout mode."))
+         (let ((flow-options (cddr clause)))
+           (%require-configuration-options
+            flow-options '(:new-tiled-client-position :close-focus-direction)
+            ":LAYOUT-FLOW")
+           (push (list (second clause) flow-options) layout-flow-options)))
+        (:command
+         (unless (second clause)
+           (error ":COMMAND needs an id."))
+         (let ((command-options (cddr clause)))
+           (%require-configuration-options
+            command-options '(:label :description :category :key :action) ":COMMAND")
+           (unless (member :action command-options)
+             (error ":COMMAND ~S needs an :ACTION." (second clause)))
+           (push (list (second clause) command-options) commands)))
+        (:bind
+         (unless (and (second clause) (third clause))
+           (error ":BIND needs a key and a command id."))
+         (let ((binding-options (cdddr clause)))
+           (%require-configuration-options
+            binding-options '(:modifiers :description) ":BIND")
+           (push (list (second clause) (third clause) binding-options) bindings)))
+        (:navigation-keys
+         (%require-configuration-options (rest clause) '(:modifiers) ":NAVIGATION-KEYS")
+         ;; Expand into ordinary named commands/bindings, so validation,
+         ;; configuration reload, and custom overrides share the usual path.
+         (let ((modifiers (%configuration-option
+                           (rest clause) :modifiers
+                           (%configuration-option (cdr (assoc :options clauses))
+                                                  :default-modifiers ''(:mod-4)))))
+           (loop for slot from 1 to 10 for key across "1234567890" do
+             (dolist (kind '(:activity :view))
+               (let* ((view-p (eq kind :view))
+                      (id (intern (format nil "NAVIGATE-~A-~D" kind slot) :keyword))
+                      (label (format nil "Select ~A slot ~D" (if view-p "local View" "Activity") slot)))
+                 (push (list id (list :label label :category "Navigation"
+                                      :action `(lambda (backend)
+                                                 (,(if view-p 'lime.x11:backend-select-view-slot
+                                                       'lime.x11:backend-select-activity-slot) backend ,slot)))) commands)
+                 (push (list key id (list :modifiers (if view-p
+                                                       `(lime.x11::%default-modifiers ,modifiers '(:shift))
+                                                       modifiers))) bindings))))))
+        (:rule
+         (let ((rule-options (rest clause)))
+           (%require-configuration-options
+            rule-options '(:id :name :class :title :predicate :float :center) ":RULE")
+           (incf rule-number)
+           (push (list rule-number rule-options) rules)))
+        (:bar
+         (when bar-options
+           (error "DEFCONFIGURATION accepts only one :BAR clause."))
+         (setf bar-options (rest clause))
+         (%require-configuration-options
+          bar-options '(:height :status-providers :padding-x :background :foreground
+                        :focused-background :focused-foreground
+                        :unfocused-background :unfocused-foreground
+                        :accent-color :menu-label-color :logo-color
+                        :separator-color :title-edge-color :attention-color
+                        :attention-marker :attention-indicator-p) ":BAR"))
+        (:font
+         (when font-supplied-p (error "DEFCONFIGURATION accepts only one :FONT clause."))
+         (setf font-options (rest clause) font-supplied-p t)
+         (%require-configuration-options font-options '(:family :size :weight) ":FONT"))
+        (:cursor
+         (when cursor-supplied-p (error "DEFCONFIGURATION accepts only one :CURSOR clause."))
+         (setf cursor-options (rest clause) cursor-supplied-p t)
+         (%require-configuration-options cursor-options '(:theme :size) ":CURSOR"))
+        (:appearance
+         (when appearance-supplied-p
+           (error "DEFCONFIGURATION accepts only one :APPEARANCE clause."))
+         (setf appearance-options (rest clause) appearance-supplied-p t)
+         (%require-configuration-options
+          appearance-options '(:border-width :focused-border :unfocused-border
+                               :inner-gap :outer-gap) ":APPEARANCE"))
+        (:startup
+         (unless (= (length (rest clause)) 1)
+           (error ":STARTUP needs exactly one function expression."))
+         (push (second clause) startup-hooks))
+        (otherwise
+         (error "DEFCONFIGURATION does not understand ~S." (first clause)))))
+    (let ((configuration (gensym "CONFIGURATION")))
+      `(progn
+         (defparameter ,name
+           (let ((,configuration
+                   (lime.x11:make-lime-configuration
+                    :appearance (lime.x11:make-window-appearance ,@appearance-options)
+                    :font (lime.x11:make-ui-font-style ,@font-options)
+                    :cursor (lime.x11:make-ui-cursor-style ,@cursor-options)
+                    :default-keybindings-p
+                    ,(%configuration-option options :default-keybindings nil)
+                    :default-modifiers
+                    ,(%configuration-option options :default-modifiers ''(:mod-4))
+                    :default-layout
+                    ,(%configuration-option options :default-layout :master-stack)
+                    :new-client-focus-p
+                    ,(%configuration-option options :new-client-focus t)
+                    :new-tiled-client-position
+                    ,(%configuration-option options :new-tiled-client-position :back)
+                    :close-focus-direction
+                    ,(%configuration-option options :close-focus-direction :previous)
+                    :layout-client-flow-policies
+                    (list
+                     ,@(mapcar
+                        (lambda (entry)
+                          (destructuring-bind (layout-mode flow-options) entry
+                            `(lime.x11:make-layout-client-flow-policy
+                              :layout-mode ',layout-mode
+                              :new-tiled-client-position
+                              ,(%configuration-option
+                                flow-options :new-tiled-client-position :back)
+                              :close-focus-direction
+                              ,(%configuration-option
+                                flow-options :close-focus-direction :previous))))
+                        (nreverse layout-flow-options))))))
+             ,@(mapcar
+                (lambda (entry)
+                  (destructuring-bind (id command-options) entry
+                    `(push
+                      (lime.x11:make-lime-command
+                       :id ',id
+                       :label ,(%configuration-option command-options :label
+                                                         (%configuration-command-label id))
+                       :description ,(%configuration-option command-options :description nil)
+                       :category ,(%configuration-option command-options :category "User")
+                       :key ,(%configuration-option command-options :key nil)
+                       :action ,(%configuration-option command-options :action))
+                      (lime.x11:lime-configuration-commands ,configuration))))
+                (nreverse commands))
+             (setf (lime.x11:lime-configuration-commands ,configuration)
+                   (nreverse (lime.x11:lime-configuration-commands ,configuration)))
+             ,@(mapcar
+                (lambda (entry)
+                  (destructuring-bind (key command-id binding-options) entry
+                    `(push
+                      (lime.x11:make-configuration-binding
+                       :key ,key
+                       :command-id ',command-id
+                       :modifiers
+                       ,(%configuration-option
+                         binding-options :modifiers
+                         `(lime.x11:lime-configuration-default-modifiers ,configuration))
+                       :description ,(%configuration-option binding-options :description nil))
+                      (lime.x11:lime-configuration-bindings ,configuration))))
+                (nreverse bindings))
+             (setf (lime.x11:lime-configuration-bindings ,configuration)
+                   (nreverse (lime.x11:lime-configuration-bindings ,configuration)))
+             ,@(mapcar
+                (lambda (entry)
+                  (destructuring-bind (number rule-options) entry
+                    `(push
+                      (lime.x11:make-window-rule
+                       :id ',(%configuration-option rule-options :id
+                                                       (intern (format nil "RULE-~D" number)
+                                                               :keyword))
+                       :resource-name ,(%configuration-option rule-options :name nil)
+                       :resource-class ,(%configuration-option rule-options :class nil)
+                       :title ,(%configuration-option rule-options :title nil)
+                       :predicate ,(%configuration-option rule-options :predicate nil)
+                       :float-p ,(%configuration-option rule-options :float nil)
+                       :center-p ,(%configuration-option rule-options :center nil))
+                      (lime.x11:lime-configuration-rules ,configuration))))
+                (nreverse rules))
+             (setf (lime.x11:lime-configuration-rules ,configuration)
+                   (nreverse (lime.x11:lime-configuration-rules ,configuration)))
+             ,@(when (member :height bar-options)
+                 `((setf (lime.x11:lime-configuration-bar-height ,configuration)
+                         ,(%configuration-option bar-options :height)
+                         (lime.x11:lime-configuration-bar-height-supplied-p ,configuration) t)))
+             (setf (lime.x11:lime-configuration-bar-style ,configuration)
+                   (lime.x11:make-head-bar-style
+                    ,@(loop for (key value) on bar-options by #'cddr
+                            unless (member key '(:height :status-providers))
+                              append (list key value))))
+             ,@(when (member :status-providers bar-options)
+                 `((setf (lime.x11:lime-configuration-status-providers ,configuration)
+                         ,(%configuration-option bar-options :status-providers)
+                         (lime.x11:lime-configuration-status-providers-supplied-p ,configuration) t)))
+             (setf (lime.x11:lime-configuration-startup-hooks ,configuration)
+                   (list ,@(nreverse startup-hooks)))
+             ,configuration))
+         (lime.x11:register-lime-configuration ',name ,name)
+         ',name))))
+
+(defun load-configuration (path &key name)
+  "Load PATH through the DEFCONFIGURATION registry."
+  (lime.x11:load-lime-configuration path :name name))
+
+(defun apply-configuration (backend configuration &key source name)
+  "Install a prebuilt CONFIGURATION on BACKEND without running startup hooks."
+  (lime.x11:apply-lime-configuration backend configuration :source source :name name))
+
+(defun reload-configuration (backend)
+  "Reload BACKEND's original configuration file safely."
+  (lime.x11:reload-backend-configuration backend))
+
+(defun start-lime (&rest arguments)
+  "Start the X11 backend, optionally using :CONFIG-FILE and :CONFIGURATION-NAME."
+  (apply #'lime.x11:start-lime arguments))
+
+(defun run-command (backend command-id)
+  "Run a named command from BACKEND's installed user configuration."
+  (lime.x11:run-configured-command backend command-id))
+
+(defun list-commands (backend)
+  "List first-class user commands available on BACKEND."
+  (lime.x11:list-configured-commands backend))
+
+(defun find-command (backend command-id)
+  "Find one installed user command by id."
+  (lime.x11:find-configured-command backend command-id))

src/x11/cursor.lisp

@@ -0,0 +1,211 @@
+(in-package #:lime.x11)
+
+;;;; Cursor assets and resource ownership, separate from pointer routing.
+;;;; Xcursor reads files into memory; CLX owns all X resources and requests.
+
+(defstruct ui-cursor-style
+  "NIL follows Xcursor environment/Xresources/defaults; :CORE disables themes."
+  theme size)
+
+(defun %cursor-theme-name-p (value)
+  (and (stringp value) (plusp (length (string-trim '(#\Space #\Tab #\Newline) value)))
+       (notany (lambda (char) (member char '(#\Null #\Newline #\Return))) value)))
+
+(defun %validate-ui-cursor-style (style)
+  (unless (and (typep style 'ui-cursor-style)
+               (or (member (ui-cursor-style-theme style) '(nil :core))
+                   (%cursor-theme-name-p (ui-cursor-style-theme style)))
+               (or (null (ui-cursor-style-size style))
+                   (and (integerp (ui-cursor-style-size style))
+                        (<= 8 (ui-cursor-style-size style) 256))))
+    (error 'invalid-transition
+           :description "Cursor :THEME must be NIL, :CORE, or a nonblank single-line theme name; :SIZE must be NIL or 8..256 pixels."))
+  style)
+
+(defun %cursor-size-value (text)
+  (when (stringp text)
+    (let ((number (ignore-errors (parse-integer text))))
+      (when (and number (<= 8 number 256)) number))))
+
+(defun %resolve-cursor-settings (style environment-theme environment-size resource-theme resource-size dpi)
+  "Pure precedence: explicit config, environment, Xresources, system default."
+  (%validate-ui-cursor-style style)
+  (let ((dpi-number (and (stringp dpi) (ignore-errors (parse-integer dpi :junk-allowed t)))))
+    (values (or (ui-cursor-style-theme style)
+                (and (%cursor-theme-name-p environment-theme) environment-theme)
+                (and (%cursor-theme-name-p resource-theme) resource-theme)
+                "default")
+            (or (ui-cursor-style-size style)
+                (%cursor-size-value environment-size) (%cursor-size-value resource-size)
+                (and dpi-number (plusp dpi-number) (min 256 (max 8 (round (* dpi-number 16/72)))))
+                24))))
+
+(declaim (ftype function %cursor-system-resources %cursor-session-report))
+(defun %backend-cursor-settings (backend style)
+  (let ((resources (%cursor-system-resources backend)))
+    (%resolve-cursor-settings
+     style (uiop:getenv "XCURSOR_THEME") (uiop:getenv "XCURSOR_SIZE")
+     (xlib:get-resource resources :|theme| :|Theme| '(:|Xcursor|) '(:|Xcursor|))
+     (xlib:get-resource resources :|size| :|Size| '(:|Xcursor|) '(:|Xcursor|))
+     (xlib:get-resource resources :|dpi| :|Dpi| '(:|Xft|) '(:|Xft|)))))
+
+(cffi:define-foreign-library ui-xcursor (:unix (:or "libXcursor.so.1" "libXcursor.so")))
+(cffi:defcstruct native-cursor-image
+  (version :uint32) (size :uint32) (width :uint32) (height :uint32)
+  (xhot :uint32) (yhot :uint32) (delay :uint32) (pixels :pointer))
+(cffi:defcstruct native-cursor-images (count :int) (images :pointer) (name :pointer))
+(cffi:defcfun ("XcursorLibraryLoadImages" %xcursor-load-images) :pointer
+  (name :string) (theme :string) (size :int))
+(cffi:defcfun ("XcursorImagesDestroy" %xcursor-free-images) :void (images :pointer))
+
+(defvar *cursor-library-loaded-p* nil)
+(defun %ensure-cursor-library ()
+  (unless *cursor-library-loaded-p*
+    (cffi:load-foreign-library 'ui-xcursor)
+    (setf *cursor-library-loaded-p* t)))
+
+(defstruct cursor-frame pixels xhot yhot delay)
+
+(defun %copy-native-cursor-frames (images)
+  "Copy bounded native data before releasing Xcursor's allocation."
+  (let ((count (cffi:foreign-slot-value images '(:struct native-cursor-images) 'count))
+        (array (cffi:foreign-slot-value images '(:struct native-cursor-images) 'images)))
+    (unless (and (<= 1 count 256) (not (cffi:null-pointer-p array)))
+      (error "Invalid cursor animation frame count."))
+    (loop for i below count for frame = (cffi:mem-aref array :pointer i)
+          collect
+          (progn
+            (when (cffi:null-pointer-p frame) (error "Missing cursor image."))
+            (cffi:with-foreign-slots ((width height xhot yhot delay pixels) frame (:struct native-cursor-image))
+              (unless (and (<= 1 width 512) (<= 1 height 512) (< xhot width) (< yhot height)
+                           (not (cffi:null-pointer-p pixels)))
+                (error "Invalid cursor dimensions or hotspot."))
+              (let ((copy (make-array (list height width) :element-type '(unsigned-byte 32))))
+                (dotimes (index (* width height))
+                  (setf (row-major-aref copy index) (cffi:mem-aref pixels :uint32 index)))
+                (make-cursor-frame :pixels copy :xhot xhot :yhot yhot :delay (max 1 delay))))))))
+
+(defun %load-cursor-frames (names theme size)
+  (%ensure-cursor-library)
+  (dolist (name names)
+    (let ((images (%xcursor-load-images name theme size)))
+      (unless (cffi:null-pointer-p images)
+        (return-from %load-cursor-frames
+          (unwind-protect (values (%copy-native-cursor-frames images) name)
+            (%xcursor-free-images images))))))
+  (error "No cursor ~S in theme ~S or its Xcursor fallbacks." names theme))
+
+(defun %make-core-cursor (backend glyph)
+  (let ((font (xlib:open-font (x11-backend-display backend) "cursor")))
+    (unwind-protect
+         (xlib:create-glyph-cursor
+          :source-font font :source-char glyph :mask-font font :mask-char (1+ glyph)
+          :foreground (xlib:make-color :red 0 :green 0 :blue 0)
+          :background (xlib:make-color :red 1 :green 1 :blue 1))
+      (xlib:close-font font))))
+
+(defun %make-render-cursor-frame (backend frame format)
+  (let* ((pixels (cursor-frame-pixels frame))
+         (pixmap nil) (gc nil) (picture nil) (cursor nil) (success nil))
+    (unwind-protect
+         (progn
+           (setf pixmap (xlib:create-pixmap :drawable (x11-backend-root backend) :depth 32
+                                          :width (array-dimension pixels 1) :height (array-dimension pixels 0))
+                 gc (xlib:create-gcontext :drawable pixmap))
+           (xlib:put-image pixmap gc (xlib:create-image :data pixels :depth 32 :bits-per-pixel 32) :x 0 :y 0)
+           (setf picture (xlib:render-create-picture pixmap :format format)
+                 ;; CLX provides these RENDER requests but does not export them.
+                 cursor (xlib::render-create-cursor picture (cursor-frame-xhot frame) (cursor-frame-yhot frame)))
+           (xlib:display-finish-output (x11-backend-display backend))
+           (setf success t)
+           cursor)
+      (when (and cursor (not success)) (xlib:free-cursor cursor))
+      (when picture (xlib:render-free-picture picture))
+      (when gc (xlib:free-gcontext gc))
+      (when pixmap (xlib:free-pixmap pixmap)))))
+
+(defun %make-themed-cursor (backend names theme size)
+  (let ((display (x11-backend-display backend)))
+    (unless (xlib:query-extension display "RENDER") (error "X server has no RENDER extension."))
+    (multiple-value-bind (major minor) (xlib:render-query-version display)
+      (unless (or (plusp major) (>= minor 5)) (error "X server lacks ARGB cursor support."))
+      (let ((format (xlib:find-standard-picture-format display :argb32)))
+        (unless format (error "X server has no ARGB32 picture format."))
+        (multiple-value-bind (frames name) (%load-cursor-frames names theme size)
+          (let* ((animated-p (and (rest frames) (or (plusp major) (>= minor 8))))
+                 (used-frames (if animated-p frames (list (first frames))))
+                 (cursors nil) (result nil) (success nil))
+            (unwind-protect
+                 (progn
+                   (dolist (frame used-frames) (push (%make-render-cursor-frame backend frame format) cursors))
+                   (setf cursors (nreverse cursors)
+                         result (if animated-p
+                                    (xlib::render-create-anim-cursor cursors (mapcar #'cursor-frame-delay used-frames))
+                                    (first cursors)))
+                   (xlib:display-finish-output display)
+                   (setf success t)
+                   (values result (list :source :theme :name name :frames (length used-frames)
+                                        :width (array-dimension (cursor-frame-pixels (first frames)) 1)
+                                        :height (array-dimension (cursor-frame-pixels (first frames)) 0))))
+              (dolist (cursor cursors)
+                (unless (and success (eq cursor result)) (xlib:free-cursor cursor)))
+              (when (and (not success) result (not (member result cursors))) (xlib:free-cursor result)))))))))
+
+(defun %load-pointer-cursor (backend names glyph theme size)
+  (let ((reason "Core cursors explicitly requested."))
+    (unless (eq theme :core)
+      (handler-case (return-from %load-pointer-cursor (%make-themed-cursor backend names theme size))
+        (error (condition) (setf reason (princ-to-string condition)))))
+    (values (%make-core-cursor backend glyph) (list :source :core :reason reason))))
+
+(defstruct x11-cursor-set arrow hand report)
+
+(defun x11-backend-root-cursor (backend)
+  (let ((set (x11-backend-cursor-set backend))) (and set (x11-cursor-set-arrow set))))
+(defun x11-backend-hand-cursor (backend)
+  (let ((set (x11-backend-cursor-set backend))) (and set (x11-cursor-set-hand set))))
+
+(defun %free-cursor-set (set)
+  (when set
+    (when (x11-cursor-set-arrow set) (xlib:free-cursor (x11-cursor-set-arrow set)))
+    (when (x11-cursor-set-hand set) (xlib:free-cursor (x11-cursor-set-hand set)))
+    (setf (x11-cursor-set-arrow set) nil (x11-cursor-set-hand set) nil)))
+
+(defun %prepare-cursor-set (backend style)
+  "Prepare a complete replacement without touching any displayed cursor."
+  (multiple-value-bind (theme size) (%backend-cursor-settings backend style)
+    (let ((set (make-x11-cursor-set)) (success nil))
+      (unwind-protect
+           (progn
+             (multiple-value-bind (cursor info) (%load-pointer-cursor backend '("left_ptr" "default") 68 theme size)
+               (setf (x11-cursor-set-arrow set) cursor
+                     (x11-cursor-set-report set) (list :theme theme :size size :arrow info)))
+             (multiple-value-bind (cursor info) (%load-pointer-cursor backend '("hand2" "pointer") 60 theme size)
+               (setf (x11-cursor-set-hand set) cursor (getf (x11-cursor-set-report set) :hand) info))
+             (xlib:display-finish-output (x11-backend-display backend))
+             (setf success t)
+             set)
+        (unless success (%free-cursor-set set))))))
+
+(declaim (ftype function %refresh-ui-cursors))
+(defun %install-cursor-set (backend set)
+  (setf (x11-backend-cursor-set backend) set
+        (xlib:window-cursor (x11-backend-root backend)) (if set (x11-cursor-set-arrow set) :none))
+  (%refresh-ui-cursors backend))
+
+(defun %initialize-pointer-cursors (backend)
+  (%install-cursor-set backend (%prepare-cursor-set backend (make-ui-cursor-style))))
+
+(defun %shutdown-pointer-cursors (backend)
+  (setf (xlib:window-cursor (x11-backend-root backend)) :none)
+  (%free-cursor-set (x11-backend-cursor-set backend))
+  (setf (x11-backend-cursor-set backend) nil))
+
+(defun backend-cursor-report (backend)
+  "Report requested/resolved settings and per-role themed/core fallback details.
+
+THEME is the search theme, not necessarily the source of the file: Xcursor
+handles inherited themes and the system default when a requested asset is absent."
+  (let ((set (x11-backend-cursor-set backend)))
+    (and set (append (copy-tree (x11-cursor-set-report set))
+                     (list :session (%cursor-session-report backend))))))

src/x11/default-bindings.lisp

@@ -0,0 +1,177 @@
+(in-package #:lime.x11)
+
+;;;; Configurable starter keymap
+;;;
+;;; INPUT owns passive grabs and dispatch.  This optional layer is only a
+;;; collection of command-layer choices: it carries no X11 event knowledge,
+;;; Activity state, or lease policy of its own.  Its generic bindings make a
+;;; fresh Lime session usable while the small named-binding helpers leave
+;;; Activity/View naming entirely to the user's Lisp configuration.
+
+(defun %default-modifiers (modifiers extra)
+  (typecase modifiers
+    (integer
+     (logior modifiers
+             (if extra
+                 (apply #'xlib:make-state-mask extra)
+                 0)))
+    (list (append modifiers extra))
+    (otherwise
+     (error 'invalid-transition
+            :description "Default keymap modifiers must be an integer mask or modifier list."))))
+
+(defun bind-head-key (backend key head-id
+                      &key (modifiers '(:mod-4)) description)
+  "Bind KEY to select HEAD-ID using MODIFIERS.
+
+This is deliberately a thin named configuration helper rather than part of
+the universal starter keymap: physical output names belong to user config."
+  (bind-key backend key modifiers
+            (lambda (bound-backend)
+              (backend-select-head bound-backend head-id))
+            :description (or description
+                             (format nil "Select Head ~A" head-id))))
+
+(defun bind-view-key (backend key view-id
+                      &key (modifiers '(:mod-4))
+                        (policy :strict) description)
+  "Bind KEY to activate VIEW-ID with an explicit lease collision POLICY.
+
+POLICY is :STRICT, :PARTIAL, or :TAKE.  Strict is the safe default; a future
+interactive picker can preflight and present all three choices."
+  (bind-key backend key modifiers
+            (lambda (bound-backend)
+              (backend-activate-view bound-backend view-id :policy policy))
+            :description (or description
+                             (format nil "Open View ~A (~(~A~))" view-id policy))))
+
+(defun bind-viewset-key (backend key viewset-id
+                         &key (modifiers '(:mod-4))
+                           (policy :strict) description)
+  "Bind KEY to atomically recall VIEWSET-ID with explicit collision POLICY.
+
+Unlike BIND-VIEW-KEY, this operation targets every Head named by the saved
+Viewset. It is intentionally opt-in configuration: personal work-desk and
+game-desk names should remain Lisp data, not universal default bindings."
+  (bind-key backend key modifiers
+            (lambda (bound-backend)
+              (backend-activate-viewset bound-backend viewset-id :policy policy))
+            :description (or description
+                             (format nil "Open Viewset ~A (~(~A~))"
+                                     viewset-id policy))))
+
+(defun bind-activity-key (backend key activity-id
+                          &key view-id (modifiers '(:mod-4))
+                            (policy :strict) description)
+  "Bind KEY to open ACTIVITY-ID's live draft, or supplied VIEW-ID.
+
+The command verifies that VIEW-ID belongs to ACTIVITY-ID.  Omitting it resumes
+the Activity's unsaved Head-local draft, creating a blank draft when needed."
+  (bind-key backend key modifiers
+            (lambda (bound-backend)
+              (backend-activate-activity bound-backend activity-id
+                                         :view-id view-id :policy policy))
+            :description (or description
+                             (format nil "Open Activity ~A" activity-id))))
+
+(defun install-default-keybindings
+    (backend &key (modifiers '(:mod-4)) (clear-existing-p nil))
+  "Install Lime's small generic Super keymap and return its bindings.
+
+The default keymap deliberately has no Activity, View, or physical Head names:
+use BIND-ACTIVITY-KEY, BIND-VIEW-KEY, and BIND-HEAD-KEY for those personal
+choices.  Its generic keys follow the user's existing dwm muscle memory. Set
+CLEAR-EXISTING-P to remove a prior configuration before this keymap is
+installed.
+
+  Super-1..9,0                   select Activity slot 1..10
+  Super-Shift-1..9,0             select local View slot 1..10
+  Super-t / Super-h              focus next / previous visible client
+  Super-Shift-t / Super-Shift-h  move focused tiled client forward / backward
+  Super-Return / Super-z          promote / focus primary tiled client
+  Super-Shift-Return               launch st
+  Super-b                           launch Waterfox
+  Super-Tab / Super-Shift-Tab     cycle layout forward / backward
+  Super-d / Super-n               shrink / grow master area
+  Super-Up / Super-Down           add / remove a master client (minimum one)
+  Super-space                     toggle focused client float
+  Super-f                         toggle focused client fullscreen
+  Super-i / Super-Shift-i         show hidden window / hide focused window
+  Super-Shift-c                   close focused client
+  Super-Shift-q                   quit Lime cleanly
+  Super-Shift-s                   update the mounted saved View
+  Super-p                         launch a PATH program (dmenu_run-like picker)
+  Super-y                         open the Activity/View command palette
+  Super-e / Super-Shift-e         select next Head / send client to next Head"
+  (when clear-existing-p
+    (clear-keybindings backend))
+  (flet ((bind (key extra handler description)
+           (bind-key backend key (%default-modifiers modifiers extra)
+                     handler :description description)))
+    (append
+     (loop for slot from 1 to 10 for key across "1234567890" append
+       (let ((number slot))
+         (list (bind key '() (lambda (b) (backend-select-activity-slot b number))
+                     (format nil "Select Activity slot ~D" number))
+               (bind key '(:shift) (lambda (b) (backend-select-view-slot b number))
+                     (format nil "Select local View slot ~D" number)))))
+     (list
+     (bind #\t '() #'backend-focus-next-client "Focus next visible client")
+     (bind #\h '() #'backend-focus-previous-client "Focus previous visible client")
+     (bind #\t '(:shift) (lambda (bound-backend)
+                            (backend-swap-focused-client bound-backend
+                                                         :direction :next))
+           "Move focused tiled client forward")
+     (bind #\h '(:shift) (lambda (bound-backend)
+                            (backend-swap-focused-client bound-backend
+                                                         :direction :previous))
+           "Move focused tiled client backward")
+     ;; In Common Lisp #\Newline names the line-feed character, which CLX
+     ;; maps to X11's Linefeed keysym (not the physical Return key).  Use
+     ;; #\Return explicitly for the normal main-keyboard Return binding.
+     (bind #\Return '() #'backend-promote-focused-client
+           "Promote focused client to master")
+     (bind #\z '() #'backend-focus-master-client "Focus primary tiled client")
+     (bind #\Return '(:shift) #'backend-launch-terminal
+           "Launch terminal (st)")
+     (bind #\b '() #'backend-launch-browser "Launch browser (Waterfox)")
+     (bind #\Tab '() (lambda (bound-backend)
+                        (backend-cycle-layout bound-backend :direction :next))
+           "Cycle layout forward")
+     (bind #\Tab '(:shift) (lambda (bound-backend)
+                              (backend-cycle-layout bound-backend :direction :previous))
+           "Cycle layout backward")
+     (bind #\d '() (lambda (bound-backend)
+                      (backend-adjust-master-stack-ratio bound-backend (- 1/20)))
+           "Shrink master area")
+     (bind #\n '() (lambda (bound-backend)
+                      (backend-adjust-master-stack-ratio bound-backend 1/20))
+           "Grow master area")
+     (bind #xFF52 '() (lambda (bound-backend)
+                         (backend-adjust-master-stack-count bound-backend 1))
+           "Add master client")
+     (bind #xFF54 '() (lambda (bound-backend)
+                         (backend-adjust-master-stack-count bound-backend -1))
+           "Remove master client")
+     (bind #\Space '() #'backend-toggle-focused-client-floating
+           "Toggle focused client floating")
+     (bind #\f '() #'backend-toggle-focused-client-fullscreen
+           "Toggle focused client fullscreen")
+     (bind #\i '() #'backend-open-hidden-client-picker
+           "Show a hidden window from this Activity")
+     (bind #\i '(:shift) #'backend-hide-focused-client
+           "Hide focused window in this Activity")
+     (bind #\c '(:shift) #'backend-close-focused-client "Close focused client")
+     (bind #\q '(:shift) #'backend-request-quit "Quit Lime cleanly")
+     (bind #\s '(:shift) #'backend-open-view-update-picker
+           "Choose a saved view to replace")
+     (bind #\p '() #'backend-open-run-prompt "Launch PATH program")
+     (bind #\y '() #'backend-open-command-palette
+           "Open Activity/View command palette")
+     (bind #\e '() (lambda (bound-backend)
+                      (backend-select-relative-head bound-backend :next))
+           "Select next Head")
+     (bind #\e '(:shift) (lambda (bound-backend)
+                             (backend-send-focused-client-relatively
+                              bound-backend :next))
+           "Send focused client to next Head")))))

src/x11/development-package.lisp

@@ -0,0 +1,33 @@
+(defpackage #:lime.dev
+  (:use #:cl)
+  (:documentation
+   "Development runtime for a live Lime X11 session.
+
+The package deliberately keeps the production adapter free of Slynk and
+threading policy. Its public calls serialize REPL work onto Lime's X event
+thread, which is the only supported way to inspect or change a live backend
+while the developer event loop is running.")
+  (:export
+   #:development-session
+   #:development-session-backend
+   #:development-session-repl-port
+   #:development-session-event-thread
+   #:development-session-reload-generation
+   #:development-session-last-reload-report
+   #:development-reload-report
+   #:development-reload-report-system
+   #:development-reload-report-success-p
+   #:development-reload-report-generation
+   #:development-reload-report-condition
+   #:*development-session*
+   #:start-development-session
+   #:run-development-session
+   #:stop-development-session
+   #:restart-development-session
+   #:resume-development-session
+   #:save-development-session
+   #:call-in-development-session
+   #:with-development-backend
+   #:reload-development-code
+   #:reload-development-configuration
+   #:development-status))

src/x11/development.lisp

@@ -0,0 +1,505 @@
+(in-package #:lime.dev)
+
+;;;; Live developer runtime
+;;;
+;;; A window manager owns a single X connection and mutates one model world.
+;;; Slynk evaluates REPL requests on its own threads, so sending those requests
+;;; straight to the backend would race the CLX event loop. This module keeps
+;;; the normal adapter unopinionated and gives development sessions one small,
+;;; explicit mailbox: all supported live work runs at an event-loop boundary.
+
+(defstruct development-request
+  function
+  values
+  failure
+  (completed-p nil))
+
+(defstruct development-reload-report
+  "Outcome of one source reload attempted by RELOAD-DEVELOPMENT-CODE."
+  system
+  generation
+  (success-p nil)
+  condition)
+
+(defstruct (development-session (:constructor %make-development-session))
+  "One running Lime backend plus its developer control boundary."
+  backend
+  start-arguments
+  repl-port
+  (repl-running-p nil)
+  event-timeout
+  event-thread
+  ;; The mailbox protects only request bookkeeping. Request functions always
+  ;; run outside this lock, on the X event thread, so they may safely invoke
+  ;; normal adapter commands and configuration reloads.
+  (lock (bt:make-lock "Lime development session"))
+  ;; Separate from mailbox bookkeeping: stop/restart join the owner thread,
+  ;; which still needs the mailbox lock while draining pending requests.
+  (lifecycle-lock (bt:make-lock "Lime development lifecycle"))
+  (condition-variable (bt:make-condition-variable :name "Lime development requests"))
+  (pending-requests '())
+  (running-p nil)
+  (paused-p nil)
+  (restarting-p nil)
+  event-loop-condition
+  diagnostic-file
+  diagnostic-write-error
+  last-error-report
+  (reload-generation 0)
+  last-reload-report)
+
+(defvar *development-session* nil
+  "The one developer session started in this Lisp image, if any.")
+
+(defun %development-session-or-error (session)
+  (or session *development-session*
+      (error "No Lime development session is running in this Lisp image.")))
+
+(defun %plist-without (arguments removed-keys)
+  (loop for (key value) on arguments by #'cddr
+        unless (member key removed-keys)
+          append (list key value)))
+
+(defun %enqueue-development-request (session request)
+  (bt:with-lock-held ((development-session-lock session))
+    (unless (and (development-session-running-p session)
+                 (not (development-session-restarting-p session)))
+      (error "The Lime development session is not accepting requests."))
+    (push request (development-session-pending-requests session)))
+  request)
+
+(defun %take-development-requests (session)
+  (bt:with-lock-held ((development-session-lock session))
+    (prog1 (nreverse (development-session-pending-requests session))
+      (setf (development-session-pending-requests session) '()))))
+
+(defun %complete-development-request (session request values failure)
+  (bt:with-lock-held ((development-session-lock session))
+    (setf (development-request-values request) values
+          (development-request-failure request) failure
+          (development-request-completed-p request) t)
+    (bt:condition-notify (development-session-condition-variable session)))
+  request)
+
+(defun %service-development-requests (session backend)
+  "Run every queued developer operation on Lime's X event thread."
+  (dolist (request (%take-development-requests session))
+    (handler-case
+        (%complete-development-request
+         session request
+         (multiple-value-list
+          (funcall (development-request-function request) backend))
+         nil)
+      (error (condition)
+        (%complete-development-request session request nil condition)))))
+
+(defun %fail-pending-development-requests (session condition)
+  (dolist (request (%take-development-requests session))
+    (%complete-development-request session request nil condition)))
+
+(defun %default-diagnostic-file (display-name)
+  (merge-pathnames
+   (format nil "lime/last-error-~A.log"
+           (map 'string (lambda (c) (if (alphanumericp c) c #\-))
+                (or display-name "default")))
+   (uiop:ensure-directory-pathname
+    (or (let ((path (uiop:getenv "XDG_STATE_HOME")))
+          (and path (plusp (length path)) path))
+        (merge-pathnames ".local/state/" (user-homedir-pathname))))))
+
+(defun %error-backtrace ()
+  #+sbcl (handler-case
+             (with-output-to-string (stream)
+               (let ((sb-debug:*debug-print-variable-alist*
+                       '((*print-length* . 8) (*print-level* . 3) (*print-circle* . t))))
+                 ;; Function names and event context suffice here; don't dump
+                 ;; session/model arguments or arbitrary user objects.
+                 (sb-debug:print-backtrace :stream stream :count 30 :argument-limit 0
+                                          :emergency-best-effort t)))
+           (error () "[Backtrace could not be printed]"))
+  #-sbcl nil)
+
+(defun %capture-session-error (session condition &optional (source :event-loop))
+  "Capture before unwinding, while the failing event's stack is still available."
+  (setf (development-session-event-loop-condition session) condition
+        (development-session-last-error-report session)
+        (lime.x11:backend-record-diagnostic
+         (development-session-backend session) condition :source source
+         :backtrace (%error-backtrace))))
+
+(defun %write-session-diagnostic (session)
+  "Keep the last fault on disk, not an unbounded per-motion log. Failure is nonfatal."
+  (let ((path (development-session-diagnostic-file session)))
+    (when path
+      (handler-case
+          (progn
+            (ensure-directories-exist path)
+            (with-open-file (stream path :direction :output :if-exists :supersede
+                                         :if-does-not-exist :create :external-format :utf-8)
+              ;; Backtraces can contain user paths/data. Make the empty file
+              ;; private before writing any contents (Lime's X11 target is Unix).
+              (unless (zerop (cffi:foreign-funcall "chmod" :string (namestring path)
+                                                  :unsigned-int #o600 :int))
+                (error "Could not make Lime's diagnostic file private."))
+              (let ((*print-pretty* t) (*print-readably* nil))
+                (format stream "Lime paused; X and the Lisp control session are retained.~%~S~%"
+                        (development-session-last-error-report session))))
+            (setf (development-session-diagnostic-write-error session) nil))
+        (error (condition)
+          (setf (development-session-diagnostic-write-error session)
+                (lime.x11::%diagnostic-condition-message condition)))))))
+
+(defun %pause-development-session (session condition)
+  "Do not stop the X session or retry potentially partial model mutations."
+  (setf (development-session-paused-p session) t
+        (development-session-event-loop-condition session) condition
+        (lime.x11::x11-backend-running-p (development-session-backend session)) nil)
+  (lime.x11:backend-release-input (development-session-backend session))
+  (%write-session-diagnostic session)
+  (ignore-errors
+    (format *error-output*
+            "~&Lime paused after an error: ~A~%Diagnostic: ~A~%Use (lime.dev:development-status), then (lime.dev:resume-development-session) after repair.~%"
+            condition (or (development-session-diagnostic-file session) "in-memory only")))
+  session)
+
+(defun %run-development-event-loop (session)
+  (loop while (development-session-running-p session)
+        do (if (development-session-paused-p session)
+               (progn
+                 ;; The same owner thread remains available for inspection,
+                 ;; source/config repair, resume, or an explicit quit request.
+                 (%service-development-requests session (development-session-backend session))
+                 (when (lime.x11::x11-backend-quit-requested-p (development-session-backend session))
+                   (setf (development-session-running-p session) nil))
+                 (sleep (development-session-event-timeout session)))
+               (handler-case
+                   (progn
+                     (handler-bind ((error (lambda (condition)
+                                             (%capture-session-error session condition))))
+                       (lime.x11:run-event-loop
+                        (development-session-backend session)
+                        :timeout (development-session-event-timeout session)
+                        :before-event
+                        (lambda (backend) (%service-development-requests session backend))))
+                     ;; Only a normal return (explicit quit/stop) ends the owner.
+                     (setf (development-session-running-p session) nil))
+                 (error (condition) (%pause-development-session session condition)))))
+  (%fail-pending-development-requests
+   session (make-condition 'simple-error :format-control "Lime event loop stopped."))
+  session)
+
+(defun %start-slynk (port)
+  "Start a loopback-only Slynk server and return PORT."
+  ;; LIME/DEV depends on Slynk while the normal Lime systems intentionally do
+  ;; not. The explicit interface prevents a development WM from listening on
+  ;; the LAN by accident.
+  (slynk:create-server :port port :dont-close t :interface "127.0.0.1")
+  port)
+
+(defun %stop-slynk (session)
+  (when (development-session-repl-running-p session)
+    (ignore-errors (slynk:stop-server (development-session-repl-port session)))
+    (setf (development-session-repl-running-p session) nil)))
+
+(defun start-development-session
+    (&rest arguments
+     &key
+       (repl-port 4005)
+       (start-repl-p t)
+       (event-timeout 0.05)
+       (session-file :default)
+       (diagnostic-file :default)
+     &allow-other-keys)
+  "Start Lime for interactive development and return a DEVELOPMENT-SESSION.
+
+All ordinary START-LIME keywords, including :DISPLAY-NAME and :CONFIG-FILE,
+are accepted. SESSION-FILE defaults to :DEFAULT (display-specific autosave and
+restore); pass NIL for a disposable session, or a pathname for a named desk.
+The event loop runs in its own thread; with the default
+START-REPL-P, Slynk listens only on 127.0.0.1:REPL-PORT. Use
+WITH-DEVELOPMENT-BACKEND or CALL-IN-DEVELOPMENT-SESSION from that REPL instead
+of invoking backend commands concurrently from an arbitrary Slynk thread."
+  (when (and *development-session*
+             (or (development-session-running-p *development-session*)
+                 (development-session-restarting-p *development-session*)))
+    (error "A Lime development session is already running in this Lisp image."))
+  (unless (and (integerp repl-port) (<= 1 repl-port 65535))
+    (error "Lime's Slynk port must be an integer from 1 through 65535."))
+  (unless (and (realp event-timeout) (plusp event-timeout))
+    (error "Lime's developer event timeout must be positive."))
+  (let* ((start-arguments
+           (append (%plist-without arguments '(:repl-port :start-repl-p :event-timeout :diagnostic-file :session-file))
+                   (list :session-file session-file)))
+         (backend (apply #'lime.x11:start-lime start-arguments))
+         (session (%make-development-session
+                   :backend backend
+                   :start-arguments start-arguments
+                   :repl-port repl-port
+                   :event-timeout event-timeout
+                   :diagnostic-file
+                   (if (eq diagnostic-file :default)
+                       (%default-diagnostic-file (lime.x11::x11-backend-display-name backend))
+                       (and diagnostic-file (pathname diagnostic-file)))
+                   :running-p t)))
+    (handler-case
+        (progn
+          (when start-repl-p
+            (%start-slynk repl-port)
+            (setf (development-session-repl-running-p session) t))
+          (setf (development-session-event-thread session)
+                (bt:make-thread (lambda () (%run-development-event-loop session))
+                                :name "Lime X11 event loop"))
+          (setf *development-session* session)
+          session)
+      (error (condition)
+        (%stop-slynk session)
+        (lime.x11:stop-backend backend :save-session-p nil)
+        (error condition)))))
+
+(defun %development-supervised-p (session)
+  (and session (or (development-session-running-p session)
+                   (development-session-restarting-p session))))
+
+(defun run-development-session (&rest arguments)
+  "Start a session and keep this Lisp process alive until it is stopped.
+
+Use this as the final form in an xinit/xsession launcher, where SBCL may have
+no usable standard input and would otherwise exit after START-DEVELOPMENT-
+SESSION returns. Interactive terminals normally want START-DEVELOPMENT-SESSION
+instead, so their local REPL remains available too."
+  (let ((session (apply #'start-development-session arguments)))
+    (declare (ignore session))
+    (unwind-protect
+         ;; Pauses and slow/failed explicit restarts must not end xinit. Only
+         ;; an intentional stop/quit releases the supervised session.
+         (loop while (%development-supervised-p *development-session*)
+               do (sleep 1))
+      ;; A Slynk caller may already have stopped the current session. Do not
+      ;; attempt a second ownership handoff in that ordinary case.
+      (when *development-session*
+        (stop-development-session *development-session*)))
+    *development-session*))
+
+(defun call-in-development-session (function &key session)
+  "Run FUNCTION with the live backend on its X event thread.
+
+FUNCTION receives one LIME.X11:X11-BACKEND and may use ordinary commands,
+configuration reloads, or pure inspection. Multiple values and errors are
+returned to the REPL caller. A call made by the event thread itself executes
+directly, which keeps key bindings and palette actions free of queue latency."
+  (unless (functionp function)
+    (error "A development-session request must be a function."))
+  (let ((session (%development-session-or-error session)))
+    (when (eq (bt:current-thread) (development-session-event-thread session))
+      (return-from call-in-development-session
+        (funcall function (development-session-backend session))))
+    (let ((request (make-development-request :function function)))
+      (%enqueue-development-request session request)
+      (bt:with-lock-held ((development-session-lock session))
+        (loop until (development-request-completed-p request)
+              do (progn
+                   ;; A short timeout means an unexpected event-loop death is
+                   ;; observable even on thread implementations where a
+                   ;; condition-notify raced a REPL wait.
+                   (bt:condition-wait (development-session-condition-variable session)
+                                      (development-session-lock session)
+                                      :timeout 0.25)
+                   (when (and (not (development-request-completed-p request))
+                              (or (not (development-session-running-p session))
+                                  (let ((thread (development-session-event-thread session)))
+                                    (and thread (not (bt:thread-alive-p thread))))))
+                     (error (or (development-session-event-loop-condition session)
+                                "The Lime development event loop stopped.")))))
+        (let ((failure (development-request-failure request)))
+          (if failure
+              (error failure)
+              (values-list (development-request-values request))))))))
+
+(defmacro with-development-backend ((backend &optional session) &body body)
+  "Evaluate BODY with BACKEND serialized on the active Lime event thread."
+  `(call-in-development-session
+    (lambda (,backend) ,@body)
+    :session (or ,session *development-session*)))
+
+(defun %reloadable-development-system-p (system)
+  ;; These systems contain only the regular model/UI/X11 code. LIME/DEV owns
+  ;; the executing control loop and is intentionally restarted after editing
+  ;; its own mailbox/thread implementation.
+  (member (string-downcase (string system))
+          '("lime" "lime/ui" "lime/x11")
+          :test #'string=))
+
+(defun reload-development-code (&key (system "lime/x11") session (force-p nil))
+  "Compile/load changed ordinary Lime source without replacing the live world.
+
+This is for function-level edits: commands, layouts, rendering, UI, and other
+code that preserves existing structure layouts. Changing DEFSTRUCT slots,
+package/load topology, thread ownership, or this LIME/DEV runtime itself is a
+restart boundary; use RESTART-DEVELOPMENT-SESSION for those changes. A failed
+compile returns a DEVELOPMENT-RELOAD-REPORT and leaves the existing backend
+and event loop alive."
+  (unless (%reloadable-development-system-p system)
+    (error "~S is not a hot-reloadable Lime system; restart the developer session instead."
+           system))
+  (let ((session (%development-session-or-error session)))
+    (call-in-development-session
+     (lambda (backend)
+       (handler-case
+           (progn
+             (asdf:load-system system :force force-p)
+             ;; Reconciliation makes a changed renderer, bar, or layout helper
+             ;; visible immediately without altering the Activity/View world.
+             (lime.x11:apply-active-presentation backend)
+             (let ((report
+                     (make-development-reload-report
+                      :system system
+                      :generation (incf (development-session-reload-generation session))
+                      :success-p t)))
+               (setf (development-session-last-reload-report session) report)
+               report))
+         (error (condition)
+           (let ((report
+                   (make-development-reload-report
+                    :system system
+                    :generation (development-session-reload-generation session)
+                    :success-p nil
+                    :condition condition)))
+             (setf (development-session-last-reload-report session) report)
+             report))))
+     :session session)))
+
+(defun reload-development-configuration (&key session)
+  "Reload the selected user configuration on the serialized X event thread."
+  (call-in-development-session
+   (lambda (backend)
+     (lime.x11:reload-backend-configuration backend))
+   :session (%development-session-or-error session)))
+
+(defun save-development-session (&key session replace-invalid-p)
+  "Flush the current desk to disk through the serialized owner-thread boundary."
+  (call-in-development-session
+   (lambda (backend) (lime.x11:backend-save-session backend :replace-invalid-p replace-invalid-p))
+   :session (%development-session-or-error session)))
+
+(defun development-status (&optional (session *development-session*))
+  "Return developer-runtime state plus the ordinary backend status."
+  (let ((session (%development-session-or-error session)))
+    (list :running-p (development-session-running-p session)
+          :paused-p (development-session-paused-p session)
+          :restarting-p (development-session-restarting-p session)
+          :diagnostic-file (development-session-diagnostic-file session)
+          :diagnostic-write-error (development-session-diagnostic-write-error session)
+          :last-error-report (copy-tree (development-session-last-error-report session))
+          :repl-port (and (development-session-repl-running-p session)
+                          (development-session-repl-port session))
+          :event-thread-alive-p
+          (and (development-session-event-thread session)
+               (bt:thread-alive-p (development-session-event-thread session)))
+          :reload-generation (development-session-reload-generation session)
+          :last-reload-report (development-session-last-reload-report session)
+          :event-loop-condition (development-session-event-loop-condition session)
+          :backend-status
+          (when (and (development-session-running-p session)
+                     (not (development-session-restarting-p session)))
+            (handler-case
+                (call-in-development-session
+                 (lambda (backend)
+                   (append (lime.x11:backend-status backend)
+                           (list :diagnostics (lime.x11:backend-diagnostics backend))))
+                 :session session)
+              (error (condition) (list :unavailable (lime.x11::%diagnostic-condition-message condition))))))))
+
+(defun resume-development-session (&optional (session *development-session*))
+  "Try to resume the existing world after repair; failed validation stays paused."
+  (let ((session (%development-session-or-error session)))
+    (call-in-development-session
+     (lambda (backend)
+       (when (development-session-paused-p session)
+         (handler-case
+             (handler-bind ((error (lambda (condition)
+                                     (%capture-session-error session condition :resume))))
+               (lime.x11:backend-reconcile-after-error backend)
+               (setf (development-session-paused-p session) nil
+                     (development-session-event-loop-condition session) nil))
+           (error (condition)
+             (%write-session-diagnostic session)
+             (error condition)))))
+     :session session)
+    session))
+
+(defun stop-development-session (&optional (session *development-session*))
+  "Stop the event thread, remap clients, close Slynk, and release the X server."
+  (let ((session (%development-session-or-error session)))
+    (when (eq (bt:current-thread) (development-session-event-thread session))
+      (error "Stop Lime's developer session from its control REPL, not its X event thread."))
+    (bt:with-lock-held ((development-session-lifecycle-lock session))
+      ;; Let the event loop leave at its next timeout before closing CLX. Closing
+      ;; the display first would make a concurrent EVENT-CASE an avoidable race.
+      (setf (development-session-running-p session) nil
+            (lime.x11::x11-backend-running-p (development-session-backend session)) nil)
+      (let ((thread (development-session-event-thread session)))
+        (when thread
+          (bt:join-thread thread)))
+      (%fail-pending-development-requests
+       session (make-condition 'simple-error :format-control "Lime development session stopped."))
+      (%stop-slynk session)
+      (lime.x11:stop-backend (development-session-backend session)
+                             :save-session-p (not (development-session-paused-p session)))
+      (when (eq *development-session* session)
+        (setf *development-session* nil))
+      session)))
+
+(defun restart-development-session (&optional (session *development-session*))
+  "Explicitly rebuild the backend, keeping xinit and Slynk alive even if startup fails.
+
+Unlike RESUME-DEVELOPMENT-SESSION, this constructs a new backend/world from the
+session file when enabled, reconnecting surviving windows. With persistence
+disabled it starts fresh. It never relaunches applications or their X server."
+  (let ((session (%development-session-or-error session)))
+    (when (eq (bt:current-thread) (development-session-event-thread session))
+      (error "Restart from the control REPL, not the X event thread."))
+    (bt:with-lock-held ((development-session-lifecycle-lock session))
+      (bt:with-lock-held ((development-session-lock session))
+        (when (development-session-restarting-p session)
+          (error "A Lime restart is already in progress."))
+        (unless (development-session-running-p session)
+          (error "This Lime session has stopped; start a new session instead."))
+        (setf (development-session-restarting-p session) t
+              (development-session-running-p session) nil
+              (lime.x11::x11-backend-running-p (development-session-backend session)) nil))
+      (when (development-session-event-thread session)
+        (bt:join-thread (development-session-event-thread session)))
+      (unwind-protect
+           (handler-case
+               (progn
+                 ;; Abort a normal restart before closing X if the latest desk
+                 ;; cannot be saved. Retrying that failed save may snapshot the
+                 ;; still-live backend; an event-loop fault instead uses the
+                 ;; last good disk snapshot, not a possibly partial mutation.
+                 (when (and (lime.x11::x11-backend-display (development-session-backend session))
+                            (getf (lime.x11:backend-session-status (development-session-backend session)) :enabled-p)
+                            (or (not (development-session-paused-p session))
+                                (eq :restart (getf (development-session-last-error-report session) :source))))
+                   (lime.x11:backend-save-session (development-session-backend session)))
+                 (lime.x11:stop-backend (development-session-backend session)
+                                        :save-session-p nil)
+                 (setf (development-session-backend session)
+                       (apply #'lime.x11:start-lime (development-session-start-arguments session))
+                       (development-session-paused-p session) nil
+                       (development-session-event-loop-condition session) nil))
+             (error (condition)
+               (%capture-session-error session condition :restart)
+               (setf (development-session-paused-p session) t)
+               ;; A pre-restart save can fail while the old X connection is
+               ;; still live. Do not leave a menu/drag grab trapping input.
+               (lime.x11:backend-release-input (development-session-backend session))
+               (%write-session-diagnostic session)
+               (error condition)))
+        ;; Even failed startup leaves a control mailbox/Slynk session to retry
+        ;; from, rather than returning from xinit and killing every application.
+        (setf (development-session-running-p session) t
+              (development-session-restarting-p session) nil
+              (development-session-event-thread session)
+              (bt:make-thread (lambda () (%run-development-event-loop session))
+                              :name "Lime X11 event loop")))
+      session)))

src/x11/ewmh.lisp

@@ -0,0 +1,472 @@
+(in-package #:lime.x11)
+
+;;;; Small EWMH compatibility boundary
+;;;
+;;; EWMH is deliberately adapter state.  In particular, fullscreen is an
+;;; application's temporary request to occupy the Head currently holding its
+;;; Lease; it is neither a saved View layout nor a global desktop abstraction.
+;;; That preserves Lime's Activity/View semantics while letting games and
+;;; ordinary desktop clients use the protocol they expect.
+
+(defparameter +ewmh-supported-atoms+
+  '(:_NET_SUPPORTED
+    :_NET_SUPPORTING_WM_CHECK
+    :_NET_WM_NAME
+    :_NET_CLIENT_LIST
+    :_NET_CLIENT_LIST_STACKING
+    :_NET_WM_STATE
+    :_NET_WM_STATE_FULLSCREEN
+    :_NET_WM_STATE_DEMANDS_ATTENTION
+    :_NET_ACTIVE_WINDOW
+    :_NET_CLOSE_WINDOW
+    :_NET_WM_WINDOW_TYPE
+    :_NET_WM_WINDOW_TYPE_NORMAL
+    :_NET_WM_WINDOW_TYPE_DIALOG
+    :_NET_WM_WINDOW_TYPE_UTILITY
+    :_NET_WM_WINDOW_TYPE_SPLASH
+    :_NET_WM_WINDOW_TYPE_DOCK
+    :_NET_WM_WINDOW_TYPE_DESKTOP)
+  "The deliberately small EWMH vocabulary Lime currently implements.")
+
+(defparameter +ewmh-window-type-atoms+
+  '((:_NET_WM_WINDOW_TYPE_NORMAL . :normal)
+    (:_NET_WM_WINDOW_TYPE_DIALOG . :dialog)
+    (:_NET_WM_WINDOW_TYPE_UTILITY . :utility)
+    (:_NET_WM_WINDOW_TYPE_SPLASH . :splash)
+    (:_NET_WM_WINDOW_TYPE_DOCK . :dock)
+    (:_NET_WM_WINDOW_TYPE_DESKTOP . :desktop))
+  "Recognized EWMH window types and their adapter-local names.")
+
+(defparameter +ewmh-dialog-like-window-types+ '(:dialog :utility :splash)
+  "Types that receive Lime's default centered floating placement.")
+
+(defparameter +ewmh-external-window-types+ '(:dock :desktop)
+  "Types mapped outside Activities and Views rather than tiled as task clients.")
+
+(defparameter +ewmh-wm-name-utf8+
+  (make-array 4 :element-type '(unsigned-byte 8)
+                :initial-contents '(76 105 109 101))
+  "The ASCII/UTF-8 bytes for Lime's EWMH supporting-window name.")
+
+(defun %ewmh-atom-id (backend atom)
+  (xlib:intern-atom (x11-backend-display backend) atom))
+
+(defun %ewmh-fullscreen-atom-id (backend)
+  (%ewmh-atom-id backend :_NET_WM_STATE_FULLSCREEN))
+
+(defun %ewmh-window-type-atom-alist (backend)
+  "Return (TYPE . X-ATOM-ID) pairs for Lime's recognized type vocabulary."
+  (mapcar (lambda (entry)
+            (cons (cdr entry) (%ewmh-atom-id backend (car entry))))
+          +ewmh-window-type-atoms+))
+
+(defun %ewmh-types-from-atom-ids (atom-ids type-atom-alist)
+  "Decode ATOM-IDS using TYPE-ATOM-ALIST, defaulting to the EWMH normal type.
+
+TYPE-ATOM-ALIST is deliberately ordinary data so this policy can be tested
+without a live X server.  EWMH specifies Normal as the default when a client
+does not publish _NET_WM_WINDOW_TYPE or publishes only unknown extensions."
+  (let ((types
+          (remove-duplicates
+           (loop for atom-id in atom-ids
+                 for entry = (find atom-id type-atom-alist :key #'cdr :test #'eql)
+                 when entry collect (car entry))
+           :test #'eq)))
+    (or types '(:normal))))
+
+(defun %ewmh-window-types-for-window (backend window)
+  "Read WINDOW's recognized EWMH types without changing task-model state."
+  (%ewmh-types-from-atom-ids
+   (copy-list (xlib:get-property window :_NET_WM_WINDOW_TYPE :type :ATOM))
+   (%ewmh-window-type-atom-alist backend)))
+
+(defun ewmh-client-window-types (backend client-id)
+  "Return a copy of CLIENT-ID's recognized EWMH window types, if managed."
+  (let ((types (gethash client-id (x11-backend-ewmh-window-types backend))))
+    (and types (copy-list types))))
+
+(defun %ewmh-dialog-like-window-types-p (types)
+  (not (null (intersection types +ewmh-dialog-like-window-types+ :test #'eq))))
+
+(defun %ewmh-external-window-types-p (types)
+  (not (null (intersection types +ewmh-external-window-types+ :test #'eq))))
+
+(defun ewmh-client-dialog-like-p (backend client-id)
+  "Whether CLIENT-ID has an EWMH type deserving Lime's dialog placement."
+  (%ewmh-dialog-like-window-types-p (ewmh-client-window-types backend client-id)))
+
+(defun %ewmh-add-client-window-id (client-order window-id)
+  "Append WINDOW-ID once, preserving EWMH initial-map order."
+  (if (member window-id client-order :test #'eql)
+      client-order
+      (append client-order (list window-id))))
+
+(defun %ewmh-remove-client-window-id (client-order window-id)
+  "Remove WINDOW-ID from an EWMH client order without disturbing the rest."
+  (remove window-id client-order :test #'eql))
+
+(defun %ewmh-remember-client-window (backend window)
+  (setf (x11-backend-ewmh-client-order backend)
+        (%ewmh-add-client-window-id
+         (x11-backend-ewmh-client-order backend) (xlib:window-id window)))
+  window)
+
+(defun %ewmh-forget-client-window-id (backend window-id)
+  (setf (x11-backend-ewmh-client-order backend)
+        (%ewmh-remove-client-window-id
+         (x11-backend-ewmh-client-order backend) window-id))
+  (remhash window-id (x11-backend-ewmh-external-windows backend))
+  window-id)
+
+(defun %ewmh-known-client-window-id-p (backend window-id)
+  "Whether WINDOW-ID is one of Lime's task or external EWMH clients."
+  (or (gethash window-id (x11-backend-window-clients backend))
+      (gethash window-id (x11-backend-ewmh-external-windows backend))))
+
+(defun %ewmh-live-client-order (backend)
+  "Filter stale ids before publishing EWMH's initial-map-order list."
+  (setf (x11-backend-ewmh-client-order backend)
+        (remove-if-not (lambda (window-id)
+                         (%ewmh-known-client-window-id-p backend window-id))
+                       (x11-backend-ewmh-client-order backend))))
+
+(defun %ewmh-stacking-client-order (backend)
+  "Read current root-child stacking order, filtered to EWMH client windows."
+  (multiple-value-bind (children parent root)
+      (xlib:query-tree (x11-backend-root backend))
+    (declare (ignore parent root))
+    (loop for window in children
+          for window-id = (xlib:window-id window)
+          when (%ewmh-known-client-window-id-p backend window-id)
+            collect window-id)))
+
+(defun %ewmh-write-window-list (root property window-ids)
+  (if window-ids
+      (xlib:change-property root property window-ids :WINDOW 32)
+      (xlib:delete-property root property)))
+
+(defun ewmh-sync-client-lists (backend)
+  "Publish accurate EWMH client and stacking lists for task and dock windows."
+  (when (x11-backend-display backend)
+    (let ((root (x11-backend-root backend)))
+      (%ewmh-write-window-list root :_NET_CLIENT_LIST
+                               (%ewmh-live-client-order backend))
+      (%ewmh-write-window-list root :_NET_CLIENT_LIST_STACKING
+                               (%ewmh-stacking-client-order backend))))
+  backend)
+
+(defun ewmh-adopt-client (backend client-id window)
+  "Cache WINDOW's EWMH types and add it to Lime's EWMH client inventory."
+  (setf (gethash client-id (x11-backend-ewmh-window-types backend))
+        (%ewmh-window-types-for-window backend window))
+  (%ewmh-remember-client-window backend window)
+  (%attention-refresh-client backend client-id window)
+  (ewmh-sync-client-lists backend)
+  client-id)
+
+(defun ewmh-adopt-external-window (backend window types)
+  "Map a dock/desktop WINDOW without turning it into an Activity task client.
+
+External surfaces retain the geometry supplied by their own application.  A
+later strut/work-area pass can build on this separation without teaching the
+core model about panels or wallpapers."
+  (let ((window-id (xlib:window-id window)))
+    (setf (gethash window-id (x11-backend-ewmh-external-windows backend)) window)
+    (%ewmh-remember-client-window backend window)
+    (xlib:map-window window)
+    (setf (xlib:window-priority window)
+          (if (member :dock types) :above :below))
+    (ewmh-sync-client-lists backend)
+    window))
+
+(defun ewmh-external-window-p (backend window)
+  "Whether WINDOW is an adapter-owned dock or desktop surface."
+  (not (null (gethash (xlib:window-id window)
+                      (x11-backend-ewmh-external-windows backend)))))
+
+(defun %ewmh-configure-request-includes-p (value-mask component)
+  "Whether a raw X ConfigureRequest VALUE-MASK contains COMPONENT."
+  (logbitp (ecase component
+             (:x 0)
+             (:y 1)
+             (:width 2)
+             (:height 3)
+             (:border-width 4))
+           value-mask))
+
+(defun ewmh-handle-external-configure-request
+    (backend window x y width height border-width value-mask)
+  "Honor geometry requests from an external dock/desktop WINDOW only.
+
+SubstructureRedirect sends every top-level ConfigureRequest to Lime. Regular
+task clients remain model-controlled; external EWMH surfaces own their own
+geometry until a later strut/work-area policy deliberately constrains them."
+  (when (ewmh-external-window-p backend window)
+    (xlib:with-state (window)
+      (when (%ewmh-configure-request-includes-p value-mask :x)
+        (setf (xlib:drawable-x window) x))
+      (when (%ewmh-configure-request-includes-p value-mask :y)
+        (setf (xlib:drawable-y window) y))
+      (when (%ewmh-configure-request-includes-p value-mask :width)
+        (setf (xlib:drawable-width window) (max 1 width)))
+      (when (%ewmh-configure-request-includes-p value-mask :height)
+        (setf (xlib:drawable-height window) (max 1 height)))
+      (when (%ewmh-configure-request-includes-p value-mask :border-width)
+        (setf (xlib:drawable-border-width window) border-width)))
+    (ewmh-sync-client-lists backend)
+    t))
+
+(defun ewmh-forget-external-window (backend window)
+  "Forget a withdrawn or destroyed adapter-owned external EWMH surface."
+  (when (ewmh-external-window-p backend window)
+    (%ewmh-forget-client-window-id backend (xlib:window-id window))
+    (ewmh-sync-client-lists backend))
+  window)
+
+(defun %ewmh-window-state-atoms (window)
+  "Return WINDOW's current _NET_WM_STATE atom ids without interpreting them.
+
+Unknown state atoms remain intact whenever Lime changes fullscreen.  We do not
+claim to implement maximization, above, sticky, or other state merely because
+a client happens to carry those atoms."
+  (copy-list (xlib:get-property window :_NET_WM_STATE :type :ATOM)))
+
+(defun %ewmh-set-window-state-atom (backend window atom enabled-p)
+  "Change just ATOM, preserving unrelated state and avoiding redundant notifications."
+  (let* ((atom-id (xlib:intern-atom (x11-backend-display backend) atom))
+         (old-atoms (%ewmh-window-state-atoms window))
+         (other-atoms (remove atom-id old-atoms
+                              :test #'eql))
+         (atoms (if enabled-p
+                    (cons atom-id other-atoms)
+                    other-atoms)))
+    (unless (equal atoms old-atoms)
+      (if atoms
+        (xlib:change-property window :_NET_WM_STATE atoms :ATOM 32)
+        (xlib:delete-property window :_NET_WM_STATE))))
+  enabled-p)
+
+(defun %set-ewmh-window-fullscreen-property (backend window fullscreen-p)
+  (%ewmh-set-window-state-atom backend window :_NET_WM_STATE_FULLSCREEN fullscreen-p)
+  fullscreen-p)
+
+(defun ewmh-client-fullscreen-p (backend client-id)
+  "Whether CLIENT-ID has requested Lime's supported fullscreen state."
+  (not (null (gethash client-id (x11-backend-fullscreen-clients backend)))))
+
+(defun %ewmh-active-presentation-for-client (backend client-id)
+  "Return CLIENT-ID's active Presentation, or NIL while it is parked.
+
+The model's exclusive Lease is the authoritative answer.  This helper has no
+separate monitor bookkeeping, which is what keeps fullscreen compatible with
+View activation and explicit cross-Head lease transfers."
+  (let ((lease (lease-for-client (x11-backend-world backend) client-id)))
+    (when lease
+      (let ((presentation (find-presentation
+                           (x11-backend-world backend)
+                           (lease-presentation-id lease))))
+        (and (presentation-active-p (x11-backend-world backend) presentation)
+             presentation)))))
+
+(defun ewmh-active-head-id-for-client (backend client-id)
+  "Return the active Head currently displaying CLIENT-ID, if any."
+  (let ((presentation (%ewmh-active-presentation-for-client backend client-id)))
+    (and presentation (presentation-head-id presentation))))
+
+(defun ewmh-fullscreen-client-id-for-head (backend head-id)
+  "Return HEAD-ID's currently visible fullscreen client, if one exists.
+
+The lease/presentation placement order makes this deterministic even if two
+old hidden Views later meet in one draft.  Normal fullscreen requests clear
+every prior visible request on their Head, so that fallback is only defensive."
+  (let ((presentation (current-presentation (x11-backend-world backend) head-id)))
+    (when presentation
+      (find-if (lambda (client-id) (ewmh-client-fullscreen-p backend client-id))
+               (presentation-leased-client-ids
+                (x11-backend-world backend) presentation)))))
+
+(defun ewmh-active-fullscreen-client-ids (backend)
+  "Return fullscreen clients visible on configured Heads in Head order."
+  (loop for head-id in (x11-backend-head-ids backend)
+        for client-id = (ewmh-fullscreen-client-id-for-head backend head-id)
+        when client-id collect client-id))
+
+(defun ewmh-window-requests-fullscreen-p (backend window)
+  "Recognize an initial _NET_WM_STATE_FULLSCREEN property during adoption."
+  (member (%ewmh-fullscreen-atom-id backend)
+          (%ewmh-window-state-atoms window)
+          :test #'eql))
+
+(defun %ewmh-clear-visible-fullscreen-on-head (backend head-id except-client-id)
+  (let ((presentation (current-presentation (x11-backend-world backend) head-id)))
+    (when presentation
+      (dolist (client-id (presentation-leased-client-ids
+                          (x11-backend-world backend) presentation))
+        (when (and (not (equal client-id except-client-id))
+                   (ewmh-client-fullscreen-p backend client-id))
+          (ewmh-set-client-fullscreen-state backend client-id nil))))))
+
+(defun ewmh-set-client-fullscreen-state (backend client-id fullscreen-p)
+  "Update EWMH fullscreen state without choosing focus or rendering.
+
+This is the protocol primitive.  The public command layer decides whether the
+request should select a visible client and then reconciles the display, while
+the event handler can share precisely the same operation."
+  (let ((window (gethash client-id (x11-backend-client-windows backend))))
+    (unless window
+      (error 'invalid-transition
+             :description (format nil "Client ~S has no managed X11 window."
+                                  client-id)))
+    (when fullscreen-p
+      (let ((head-id (ewmh-active-head-id-for-client backend client-id)))
+        (when head-id
+          (%ewmh-clear-visible-fullscreen-on-head backend head-id client-id))))
+    (if fullscreen-p
+        (setf (gethash client-id (x11-backend-fullscreen-clients backend)) t)
+        (remhash client-id (x11-backend-fullscreen-clients backend)))
+    (%set-ewmh-window-fullscreen-property backend window fullscreen-p)
+    client-id))
+
+(defun ewmh-forget-client (backend client-id &key window-id)
+  "Discard adapter-only EWMH state for a destroyed or withdrawn task client."
+  (remhash client-id (x11-backend-fullscreen-clients backend))
+  (remhash client-id (x11-backend-attention-clients backend))
+  (remhash client-id (x11-backend-ewmh-window-types backend))
+  (when window-id
+    (%ewmh-forget-client-window-id backend window-id))
+  (ewmh-sync-client-lists backend)
+  client-id)
+
+(defun ewmh-handle-property-notify (backend client-id window atom)
+  "Refresh EWMH metadata that Lime consumes when it changes after mapping."
+  (when (eq atom :_NET_WM_WINDOW_TYPE)
+    (setf (gethash client-id (x11-backend-ewmh-window-types backend))
+          (%ewmh-window-types-for-window backend window)))
+  nil)
+
+(defun %ewmh-make-supporting-window (backend)
+  "Create the tiny self-referencing window required by _NET_SUPPORTING_WM_CHECK."
+  (xlib:create-window
+   :parent (x11-backend-root backend)
+   :x 0 :y 0 :width 1 :height 1
+   :border-width 0 :override-redirect :on))
+
+(defun ewmh-initialize (backend)
+  "Advertise Lime's EWMH surface and identify this WM to desktop clients."
+  (let* ((display (x11-backend-display backend))
+         (root (x11-backend-root backend))
+         (supporting-window (%ewmh-make-supporting-window backend))
+         (supporting-window-id (xlib:window-id supporting-window)))
+    (setf (x11-backend-ewmh-supporting-window backend) supporting-window)
+    (xlib:change-property
+     root :_NET_SUPPORTED
+     (mapcar (lambda (atom) (xlib:intern-atom display atom))
+             +ewmh-supported-atoms+)
+     :ATOM 32)
+    ;; EWMH requires both the root and this child to point at the same small
+    ;; window; _NET_WM_NAME is intentionally UTF-8 even though "Lime" is
+    ;; ASCII today.
+    (xlib:change-property root :_NET_SUPPORTING_WM_CHECK
+                          (list supporting-window-id) :WINDOW 32)
+    (xlib:change-property supporting-window :_NET_SUPPORTING_WM_CHECK
+                          (list supporting-window-id) :WINDOW 32)
+    ;; CLX sends an 8-bit property from an octet vector, not a Lisp string.
+    (xlib:change-property supporting-window :_NET_WM_NAME +ewmh-wm-name-utf8+
+                          :UTF8_STRING 8)
+    (ewmh-sync-client-lists backend))
+  backend)
+
+(defun ewmh-shutdown (backend)
+  "Remove Lime-owned EWMH root properties and its supporting check window."
+  (let ((root (x11-backend-root backend)))
+    (xlib:delete-property root :_NET_ACTIVE_WINDOW)
+    (xlib:delete-property root :_NET_SUPPORTED)
+    (xlib:delete-property root :_NET_SUPPORTING_WM_CHECK)
+    (xlib:delete-property root :_NET_CLIENT_LIST)
+    (xlib:delete-property root :_NET_CLIENT_LIST_STACKING)
+    (when (x11-backend-ewmh-supporting-window backend)
+      (xlib:destroy-window (x11-backend-ewmh-supporting-window backend))
+      (setf (x11-backend-ewmh-supporting-window backend) nil)))
+  backend)
+
+(defun ewmh-set-active-window (backend client-id)
+  "Publish CLIENT-ID as the EWMH input-focus target, or clear it for root."
+  (let ((window (and client-id
+                     (gethash client-id (x11-backend-client-windows backend)))))
+    (if window
+        (xlib:change-property (x11-backend-root backend) :_NET_ACTIVE_WINDOW
+                              (list (xlib:window-id window)) :WINDOW 32)
+        (xlib:delete-property (x11-backend-root backend) :_NET_ACTIVE_WINDOW)))
+  client-id)
+
+(defun %ewmh-state-action-result (action currently-fullscreen-p)
+  "Interpret the EWMH remove/add/toggle action code.
+
+The return value is CURRENTLY-FULLSCREEN-P for an unsupported action so a
+malformed client message becomes a harmless no-op."
+  (case action
+    (0 nil)
+    (1 t)
+    (2 (not currently-fullscreen-p))
+    (otherwise currently-fullscreen-p)))
+
+(defun %client-message-data-value (data index)
+  (and (< index (length data)) (aref data index)))
+
+(declaim (ftype function %attention-refresh-client %attention-request
+                         backend-set-client-fullscreen
+                         backend-focus-client
+                         backend-close-client
+                         apply-active-presentation))
+
+(defun %ewmh-handle-window-state-message (backend window data)
+  (let ((client-id (%backend-client-id backend window))
+        (fullscreen-atom (%ewmh-fullscreen-atom-id backend))
+        (attention-atom (xlib:intern-atom (x11-backend-display backend)
+                                         :_NET_WM_STATE_DEMANDS_ATTENTION)))
+    (when (and client-id
+               (member (%client-message-data-value data 0) '(0 1 2))
+               (or (eql (%client-message-data-value data 1) attention-atom)
+                   (eql (%client-message-data-value data 2) attention-atom)))
+      (%attention-request
+       backend client-id
+       (%ewmh-state-action-result
+        (%client-message-data-value data 0)
+        (logtest 2 (gethash client-id (x11-backend-attention-clients backend) 0)))))
+    (when (and client-id
+               (or (eql (%client-message-data-value data 1) fullscreen-atom)
+                   (eql (%client-message-data-value data 2) fullscreen-atom)))
+      (backend-set-client-fullscreen
+       backend client-id
+       (%ewmh-state-action-result
+        (%client-message-data-value data 0)
+        (ewmh-client-fullscreen-p backend client-id))))))
+
+(defun %ewmh-handle-active-window-message (backend window)
+  (let ((client-id (%backend-client-id backend window)))
+    (when client-id
+      (let ((head-id (ewmh-active-head-id-for-client backend client-id)))
+        ;; A parked View remains parked.  Automatically mounting it would be
+        ;; an implicit collision policy, so a client may only activate an
+        ;; already visible leased presentation through this small slice.
+        (if head-id
+            (backend-focus-client backend client-id :head-id head-id)
+            (%attention-request backend client-id t))))))
+
+(defun %ewmh-handle-close-window-message (backend window)
+  (let ((client-id (%backend-client-id backend window)))
+    (when client-id
+      (backend-close-client backend client-id))))
+
+(defun ewmh-handle-client-message (backend window type format data)
+  "Handle Lime's narrow supported set of EWMH client messages.
+
+The event loop has already established that this is a CLX client-message.  We
+accept only the 32-bit EWMH form and deliberately leave unknown protocol
+requests alone instead of inventing fake desktop semantics."
+  (when (= format 32)
+    (case type
+      (:_NET_WM_STATE (%ewmh-handle-window-state-message backend window data))
+      (:_NET_ACTIVE_WINDOW (%ewmh-handle-active-window-message backend window))
+      (:_NET_CLOSE_WINDOW (%ewmh-handle-close-window-message backend window))))
+  nil)

src/x11/geometry.lisp

@@ -0,0 +1,102 @@
+(in-package #:lime.x11)
+
+;;;; ICCCM geometry adaptation
+;;;
+;;; Lime's model owns desired Head-relative rectangles. This module adapts a
+;;; resolved pixel rectangle to one client's WM_NORMAL_HINTS immediately before
+;;; CLX configures it. Nothing here changes a View, Presentation, or Lease.
+
+(defun %geometry-positive-integer-or (value fallback)
+  (if (and (integerp value) (plusp value)) value fallback))
+
+(defun %geometry-clamp (value minimum maximum)
+  (max minimum (min maximum value)))
+
+(defun %hinted-size (requested minimum maximum base increment hard-maximum)
+  "Return REQUESTED constrained to one ICCCM dimension.
+
+The normal-hint grid is BASE + N * INCREMENT. ICCCM clients normally publish
+consistent min/max/base values; malformed or impossible declarations degrade
+to the closest usable size, and an enclosing Head bound always wins over an
+oversized minimum."
+  (let* ((upper-bound (%geometry-positive-integer-or hard-maximum
+                                                     most-positive-fixnum))
+         (hinted-minimum (%geometry-positive-integer-or minimum 1))
+         (hinted-maximum (%geometry-positive-integer-or maximum upper-bound))
+         (upper (min upper-bound hinted-maximum))
+         ;; A client can demand more than an entire Head. The adapter cannot
+         ;; honor that without violating a Lime float's Head-local contract.
+         (lower (min upper (max 1 hinted-minimum)))
+         (size (%geometry-clamp (max 1 requested) lower upper))
+         (step (%geometry-positive-integer-or increment 1))
+         (anchor (if (integerp base) base (or minimum 0))))
+    (if (= step 1)
+        size
+        (let* ((lowest-index (ceiling (- lower anchor) step))
+               (highest-index (floor (- upper anchor) step)))
+          (if (> lowest-index highest-index)
+              size
+              (let ((index (%geometry-clamp
+                            (floor (- size anchor) step)
+                            lowest-index highest-index)))
+                (+ anchor (* step index))))))))
+
+(defun constrain-geometry-to-normal-hints
+    (geometry normal-hints
+     &key bounds-x bounds-y bounds-width bounds-height)
+  "Return GEOMETRY adjusted to NORMAL-HINTS and optional enclosing bounds.
+
+Minimum/maximum dimensions and base-size resize increments are honored. When
+BOUNDS-* describes a Head rectangle, the result is also kept inside it; this
+is essential when a client advertises a minimum larger than a tile or Head.
+Position changes only compensate for a size change that would otherwise leave
+those explicit bounds."
+  (let* ((bounded-width (%geometry-positive-integer-or bounds-width
+                                                        most-positive-fixnum))
+         (bounded-height (%geometry-positive-integer-or bounds-height
+                                                         most-positive-fixnum))
+         (width (%hinted-size
+                 (geometry-width geometry)
+                 (and normal-hints (xlib:wm-size-hints-min-width normal-hints))
+                 (and normal-hints (xlib:wm-size-hints-max-width normal-hints))
+                 (and normal-hints (xlib:wm-size-hints-base-width normal-hints))
+                 (and normal-hints (xlib:wm-size-hints-width-inc normal-hints))
+                 bounded-width))
+         (height (%hinted-size
+                  (geometry-height geometry)
+                  (and normal-hints (xlib:wm-size-hints-min-height normal-hints))
+                  (and normal-hints (xlib:wm-size-hints-max-height normal-hints))
+                  (and normal-hints (xlib:wm-size-hints-base-height normal-hints))
+                  (and normal-hints (xlib:wm-size-hints-height-inc normal-hints))
+                  bounded-height))
+         (x (if bounds-x
+                (%geometry-clamp (geometry-x geometry) bounds-x
+                                 (+ bounds-x (- bounded-width width)))
+                (geometry-x geometry)))
+         (y (if bounds-y
+                (%geometry-clamp (geometry-y geometry) bounds-y
+                                 (+ bounds-y (- bounded-height height)))
+                (geometry-y geometry))))
+    (make-geometry :x x :y y :width width :height height)))
+
+(defun constrain-client-geometry (backend client-id geometry &key head work-area)
+  "Adapt GEOMETRY to CLIENT-ID's cached ICCCM hints inside an adapter bound.
+
+HEAD retains the historical physical-rectangle convenience.  WORK-AREA is the
+preferred bound for normal tiled and floating clients now that a Head can
+reserve its top bar; callers must choose at most one so fullscreen paths stay
+visibly explicit."
+  (when (and head work-area)
+    (error 'invalid-transition
+           :description "Choose either a physical Head or a work area for client geometry."))
+  (let ((info (backend-client-icccm-info backend client-id)))
+    (constrain-geometry-to-normal-hints
+     geometry (and info (icccm-client-info-normal-hints info))
+     :bounds-x (cond (work-area (x11-work-area-x work-area))
+                      (head (x11-head-x head)))
+     :bounds-y (cond (work-area (x11-work-area-y work-area))
+                      (head (x11-head-y head)))
+     :bounds-width (cond (work-area (x11-work-area-width work-area))
+                          (head (x11-head-width head)))
+     :bounds-height (cond (work-area (x11-work-area-height work-area))
+                           (head (x11-head-height head))))))

src/x11/icccm.lisp

@@ -0,0 +1,231 @@
+(in-package #:lime.x11)
+
+;;;; ICCCM protocol boundary
+;;;
+;;; The Activity/View/Head model has no X atoms or client messages. This file
+;;; owns those details: it snapshots the useful client properties, responds to
+;;; property changes, and exposes protocol-aware focus, close, and Configure-
+;;; Notify operations for the lifecycle and render layers.
+
+(defstruct icccm-client-info
+  "Cached ICCCM facts for one managed X11 client.
+
+The cache is backend-only: it is UI-facing metadata and protocol capability,
+not durable Activity/View model state. NORMAL-HINTS remains the CLX
+WM-SIZE-HINTS object so a later size-aware layout policy can consume the exact
+client declaration without rereading X properties."
+  client-id
+  window-id
+  title
+  resource-name
+  resource-class
+  (protocols '())
+  (accepts-input-p t)
+  (delete-window-p nil)
+  (take-focus-p nil)
+  transient-for-client-id
+  normal-hints
+  ;; This is a cache of what Lime last wrote to WM_STATE.  It avoids emitting
+  ;; a property write on every render while keeping state protocol-local.
+  (wm-state :withdrawn))
+
+(defun backend-client-icccm-info (backend client-id)
+  "Return cached ICCCM facts for CLIENT-ID, or NIL when it is not managed."
+  (gethash client-id (x11-backend-icccm-clients backend)))
+
+(defun %protocol-member-p (protocol protocols)
+  (not (null (member protocol protocols :test #'string-equal))))
+
+(defun %refreshed-wm-state (previous-info)
+  "Keep renderer-owned WM_STATE across a metadata-only property refresh."
+  (if previous-info
+      (icccm-client-info-wm-state previous-info)
+      :withdrawn))
+
+(defun icccm-wm-state-data (state)
+  "Return the two-cardinal WM_STATE payload for STATE.
+
+The second field is the ICCCM icon-window slot, which Lime intentionally does
+not use.  :WITHDRAWN is useful for inspection, but withdrawing a real client
+removes the property rather than storing this zero value."
+  (list (ecase state
+          (:withdrawn 0)
+          (:normal 1)
+          (:iconic 3))
+        0))
+
+(defun icccm-set-client-state (backend client-id window state &key force-p)
+  "Publish STATE for CLIENT-ID when Lime's cached value changes.
+
+Lime uses :NORMAL for a client rendered in a leased Presentation and :ICONIC
+when a View hides that client.  This does not create an independent minimized
+window concept: the Activity/View lease still determines whether it appears.
+FORCE-P is reserved for the ownership handoff in STOP-BACKEND, where Lime must
+leave a normal visible state even if its local cache is stale."
+  (unless (member state '(:normal :iconic))
+    (error "WM_STATE ~S cannot be published; use ICCCM-WITHDRAW-CLIENT for withdrawal."
+           state))
+  (let ((info (backend-client-icccm-info backend client-id)))
+    (unless (and (not force-p)
+                 info
+                 (eq (icccm-client-info-wm-state info) state))
+      (xlib:change-property window :WM_STATE (icccm-wm-state-data state)
+                            :WM_STATE 32)
+      (when info
+        (setf (icccm-client-info-wm-state info) state))))
+  state)
+
+(defun icccm-withdraw-client (backend client-id window)
+  "Remove CLIENT-ID's WM_STATE property after an application withdrawal."
+  (xlib:delete-property window :WM_STATE)
+  (let ((info (backend-client-icccm-info backend client-id)))
+    (when info
+      (setf (icccm-client-info-wm-state info) :withdrawn)))
+  :withdrawn)
+
+(defun %accepts-input-p (window)
+  "Apply ICCCM's default: a missing InputHint means the client accepts input."
+  (let ((hints (xlib:wm-hints window)))
+    (not (and hints
+              (eq (xlib:wm-hints-input hints) :off)))))
+
+(defun %transient-client-id (backend window)
+  (let ((parent (xlib:transient-for window)))
+    (and parent (%backend-client-id backend parent))))
+
+(defun %nonempty-title (text)
+  (and (stringp text) (plusp (length text)) text))
+
+(defun %read-title-property (window property type encoding)
+  (multiple-value-bind (data actual-type format)
+      (xlib:get-property window property :type type :end 4096 :result-type 'vector)
+    (declare (ignore actual-type))
+    (and (= (or format 0) 8) data
+         (%nonempty-title
+          (babel:octets-to-string (coerce data '(vector (unsigned-byte 8)))
+                                 :encoding encoding :errorp nil)))))
+
+(defun %read-client-title (window)
+  "Prefer EWMH's UTF-8 title, falling back to legacy ICCCM WM_NAME.
+
+Malformed or wrongly typed modern properties must not break window adoption.
+Bound the property read; titles are display metadata, not arbitrary payloads."
+  (or (%read-title-property window :_NET_WM_NAME :UTF8_STRING :utf-8)
+      (%read-title-property window :WM_NAME :STRING :iso-8859-1)))
+
+(defun icccm-refresh-client-info (backend client-id window)
+  "Read ICCCM properties for WINDOW and replace CLIENT-ID's backend cache."
+  (multiple-value-bind (resource-name resource-class)
+      (xlib:get-wm-class window)
+    (let* ((previous-info (backend-client-icccm-info backend client-id))
+           (protocols (xlib:wm-protocols window))
+           (info (make-icccm-client-info
+                  :client-id client-id
+                  :window-id (xlib:window-id window)
+                  :title (%read-client-title window)
+                  :resource-name resource-name
+                  :resource-class resource-class
+                  :protocols (copy-list protocols)
+                  :accepts-input-p (%accepts-input-p window)
+                  :delete-window-p (%protocol-member-p "WM_DELETE_WINDOW"
+                                                       protocols)
+                  :take-focus-p (%protocol-member-p "WM_TAKE_FOCUS" protocols)
+                  :transient-for-client-id (%transient-client-id backend window)
+                  :normal-hints (xlib:wm-normal-hints window)
+                  ;; A property refresh must not forget whether Lime already
+                  ;; hid this client. Otherwise an unrelated title/hint change
+                  ;; could queue a redundant unmap and leave a false pending
+                  ;; token for a later genuine withdrawal.
+                  :wm-state (%refreshed-wm-state previous-info))))
+      (setf (gethash client-id (x11-backend-icccm-clients backend)) info)
+      info)))
+
+(defun icccm-adopt-client (backend client-id window)
+  "Begin tracking client properties and cache its current ICCCM declaration."
+  ;; Event masks are selected per X client, so this does not disturb the
+  ;; client's own selections. Property changes let a future UI see title/class
+  ;; updates and keep focus/close capabilities current.
+  (setf (xlib:window-event-mask window)
+        (logior (xlib:window-event-mask window)
+                (xlib:make-event-mask :property-change :focus-change)))
+  (icccm-refresh-client-info backend client-id window))
+
+(defun icccm-forget-client (backend client-id)
+  "Remove backend-only ICCCM state after a destroy or withdrawal."
+  (remhash client-id (x11-backend-icccm-clients backend))
+  client-id)
+
+(defun icccm-handle-client-message (backend window type format data)
+  "Recognize ICCCM messages Lime deliberately handles.
+
+Lime has no independent minimize bucket: a View is the user-facing way to
+hide a window while retaining it in its task.  Therefore a WM_CHANGE_STATE
+iconify request is recognized and safely declined rather than quietly turning
+it into a destructive withdrawal.  Returning true keeps EWMH dispatch from
+misinterpreting the ICCCM atom."
+  (declare (ignore backend window format data))
+  (eq type :WM_CHANGE_STATE))
+
+(defun icccm-handle-property-notify (backend client-id window atom)
+  "Refresh client metadata, including the EWMH override of ICCCM's title."
+  (when (member atom '(:_NET_WM_NAME :WM_NAME :WM_CLASS :WM_PROTOCOLS :WM_HINTS
+                      :WM_NORMAL_HINTS :WM_TRANSIENT_FOR))
+    (icccm-refresh-client-info backend client-id window))
+  nil)
+
+(defun %send-wm-protocol (window protocol)
+  "Send one WM_PROTOCOLS client message with CurrentTime."
+  (let ((display (xlib:window-display window)))
+    (xlib:send-event window :client-message nil
+                     :window window
+                     :format 32
+                     :type :WM_PROTOCOLS
+                     :data (list (xlib:intern-atom display protocol) 0 0 0 0))))
+
+(defun icccm-focus-client (backend client-id window)
+  "Honor InputHint and WM_TAKE_FOCUS for a rendered focus target.
+
+When a client cannot accept either kind of focus, input deliberately falls back
+to the root rather than leaving it on an unrelated hidden client."
+  (let ((info (or (backend-client-icccm-info backend client-id)
+                  (icccm-refresh-client-info backend client-id window)))
+        (delivered-p nil))
+    (when (icccm-client-info-accepts-input-p info)
+      (xlib:set-input-focus (x11-backend-display backend) window :pointer-root)
+      (setf delivered-p t))
+    (when (icccm-client-info-take-focus-p info)
+      (%send-wm-protocol window :WM_TAKE_FOCUS)
+      (setf delivered-p t))
+    (unless delivered-p
+      (xlib:set-input-focus (x11-backend-display backend)
+                            (x11-backend-root backend)
+                            :pointer-root))
+    info))
+
+(defun icccm-request-close (backend client-id window)
+  "Request CLIENT-ID close gracefully, falling back to XKillClient if needed.
+
+The client stays in Lime's model until its real DestroyNotify arrives; this
+function only asks the external client to terminate."
+  (let ((info (or (backend-client-icccm-info backend client-id)
+                  (icccm-refresh-client-info backend client-id window))))
+    (if (icccm-client-info-delete-window-p info)
+        (progn
+          (%send-wm-protocol window :WM_DELETE_WINDOW)
+          :wm-delete-window)
+        (progn
+          (xlib:kill-client (x11-backend-display backend) (xlib:window-id window))
+          :kill-client))))
+
+(defun icccm-send-configure-notify (window)
+  "Tell a tiled client the geometry actually assigned by the window manager."
+  (xlib:send-event window :configure-notify nil
+                   :event-window window
+                   :window window
+                   :above-sibling nil
+                   :x (xlib:drawable-x window)
+                   :y (xlib:drawable-y window)
+                   :width (xlib:drawable-width window)
+                   :height (xlib:drawable-height window)
+                   :border-width (xlib:drawable-border-width window)
+                   :override-redirect-p nil))

src/x11/input.lisp

@@ -0,0 +1,186 @@
+(in-package #:lime.x11)
+
+;;;; Opt-in keyboard input
+;;;
+;;; This layer translates a passive X11 key grab into a handler supplied by the
+;;; user.  Handlers receive the X11-BACKEND and normally call a command from
+;;; x11/commands.lisp.  It intentionally knows no View ids, Activity names,
+;;; menus, or collision policy itself.
+
+(defstruct keybinding
+  "One character/keysym binding owned by an X11 backend."
+  key
+  modifiers
+  state
+  keycodes
+  handler
+  description)
+
+(defun %input-keysym (display key)
+  (typecase key
+    (character
+     (or (first (xlib:character->keysyms key display))
+         (error 'invalid-transition
+                :description (format nil "No X11 keysym is known for ~S." key))))
+    ((integer 0 *) key)
+    (otherwise
+     (error 'invalid-transition
+            :description "A keybinding key must be a character or X11 keysym integer."))))
+
+(defun %input-keycodes (display key)
+  (let ((keysym (%input-keysym display key)))
+    (or (remove nil (multiple-value-list (xlib:keysym->keycodes display keysym)))
+        (error 'invalid-transition
+               :description (format nil "No X11 keycode is available for ~S." key)))))
+
+(defun %input-state (modifiers)
+  (typecase modifiers
+    (integer modifiers)
+    (list (apply #'xlib:make-state-mask modifiers))
+    (otherwise
+     (error 'invalid-transition
+            :description "Keybinding modifiers must be an integer mask or modifier list."))))
+
+(defparameter +input-ignored-state-mask+
+  ;; X11 commonly assigns Caps Lock to :LOCK and Num Lock to :MOD-2.  Neither
+  ;; should make a window-manager keybinding mysteriously stop matching.  The
+  ;; physical mapping is discovered from the server for more exotic setups in
+  ;; a later input pass; these two portable CLX names cover Lime's current
+  ;; Xorg sessions and the conventional X11 assignment.
+  (xlib:make-state-mask :lock :mod-2))
+
+(defun %input-state-variants (state)
+  "Return STATE's lock-insensitive passive-grab variants.
+
+Passive X11 grabs are exact, whereas a key press with Caps Lock or Num Lock
+active should still invoke the same command.  Register every combination and
+store all of them in the dispatch table; callers continue to expose only the
+user's original modifier list in keybinding descriptions."
+  (remove-duplicates
+   (loop for ignored-state in
+           (list 0
+                 (xlib:make-state-mask :lock)
+                 (xlib:make-state-mask :mod-2)
+                 +input-ignored-state-mask+)
+         collect (logior state ignored-state))))
+
+(defun %input-binding-key (keycode state)
+  (cons keycode state))
+
+(defun %ungrab-binding (backend binding)
+  (let ((root (x11-backend-root backend)))
+    (dolist (keycode (keybinding-keycodes binding))
+      (dolist (state (%input-state-variants (keybinding-state binding)))
+        (xlib:ungrab-key root keycode :modifiers state)))))
+
+(defun %remove-binding (backend binding)
+  "Ungrab BINDING and erase every table entry that still points to it."
+  (%ungrab-binding backend binding)
+  (let ((table (x11-backend-keybindings backend))
+        (keys '()))
+    (maphash (lambda (table-key candidate)
+               (when (eq candidate binding)
+                 (push table-key keys)))
+             table)
+    (dolist (table-key keys)
+      (remhash table-key table))))
+
+(defun bind-key (backend key modifiers handler &key description)
+  "Passively grab KEY with MODIFIERS and run HANDLER when it is pressed.
+
+KEY is a character or an X11 keysym integer.  MODIFIERS is an integer mask or
+a CLX modifier list such as '(:MOD-4).  HANDLER receives BACKEND as its sole
+argument and should invoke a command-layer operation.  Rebinding the same
+physical key/modifier pair replaces its previous handler. The passive grab
+briefly queues subsequent keyboard events until dispatch can hand them to a
+new palette grab or release them normally, even if the trigger was released."
+  (unless (functionp handler)
+    (error 'invalid-transition :description "A keybinding handler must be a function."))
+  (let* ((display (x11-backend-display backend))
+         (root (x11-backend-root backend))
+         (state (%input-state modifiers))
+         (keycodes (%input-keycodes display key))
+         (binding (make-keybinding :key key
+                                   :modifiers modifiers
+                                   :state state
+                                   :keycodes keycodes
+                                   :handler handler
+                                   :description description))
+         (table (x11-backend-keybindings backend)))
+    (dolist (keycode keycodes)
+      (let* ((table-key (%input-binding-key keycode state))
+             (old (gethash table-key table)))
+        (when old
+          (%remove-binding backend old))
+        (dolist (grab-state (%input-state-variants state))
+          (xlib:grab-key root keycode :modifiers grab-state :sync-keyboard-p t)
+          (setf (gethash (%input-binding-key keycode grab-state) table)
+                binding))))
+    (xlib:display-force-output display)
+    binding))
+
+(defun unbind-key (backend key modifiers)
+  "Release KEY/MODIFIERS and return whether at least one binding was removed."
+  (let* ((display (x11-backend-display backend))
+         (state (%input-state modifiers))
+         (keycodes (%input-keycodes display key))
+         (table (x11-backend-keybindings backend))
+         (removed-p nil))
+    (dolist (keycode keycodes)
+      (let* ((table-key (%input-binding-key keycode state))
+             (binding (gethash table-key table)))
+        (when binding
+          (%remove-binding backend binding)
+          (setf removed-p t))))
+    (xlib:display-force-output display)
+    removed-p))
+
+(defun clear-keybindings (backend)
+  "Remove every passive key grab registered through BIND-KEY."
+  (let ((seen (make-hash-table :test #'eq)))
+    (maphash (lambda (table-key binding)
+               (declare (ignore table-key))
+               (unless (gethash binding seen)
+                 (%ungrab-binding backend binding)
+                 (setf (gethash binding seen) t)))
+             (x11-backend-keybindings backend))
+    (clrhash (x11-backend-keybindings backend))
+    (xlib:display-force-output (x11-backend-display backend)))
+  backend)
+
+(defun list-keybindings (backend)
+  "Return unique KEYBINDING objects currently installed on BACKEND."
+  (let ((seen (make-hash-table :test #'eq))
+        (bindings '()))
+    (maphash (lambda (table-key binding)
+               (declare (ignore table-key))
+               (unless (gethash binding seen)
+                 (push binding bindings)
+                 (setf (gethash binding seen) t)))
+             (x11-backend-keybindings backend))
+    (nreverse bindings)))
+
+(defun backend-last-command-error (backend)
+  "Return the most recent condition raised by an input handler, if any."
+  (x11-backend-last-command-error backend))
+
+(defun %handle-key-press (backend keycode state)
+  "Dispatch a grabbed KeyPress without allowing a handler error to kill Lime."
+  (unwind-protect
+       (let ((binding (gethash (%input-binding-key keycode state)
+                              (x11-backend-keybindings backend))))
+         (when binding
+           (handler-case
+               (progn
+                 (setf (x11-backend-last-command-error backend) nil)
+                 (funcall (keybinding-handler binding) backend)
+                 t)
+             (error (condition)
+               (setf (x11-backend-last-command-error backend) condition)
+               nil))))
+    ;; A successful palette grab already thaws input into its own queue.
+    ;; Ordinary commands, failures, and removed bindings must thaw it too.
+    (let ((display (x11-backend-display backend)))
+      (when display
+        (xlib:allow-events display :async-keyboard)
+        (xlib:display-force-output display)))))

src/x11/launcher.lisp

@@ -0,0 +1,144 @@
+(in-package #:lime.x11)
+
+;;;; Process launching boundary
+;;;
+;;; Activities, Views, and leases do not know how a client was created. This
+;;; tiny adapter utility owns process creation so the palette, default bindings,
+;;; and user configuration can all launch a normal X client without growing a
+;;; second, dmenu-specific UI or leaking shell mechanics into the core model.
+
+(defun %nonblank-launch-command (command)
+  "Trim COMMAND or signal the same useful transition condition as UI commands."
+  (unless (stringp command)
+    (error 'invalid-transition :description "A launch command must be a string."))
+  (let ((trimmed (string-trim '(#\Space #\Tab #\Newline #\Return) command)))
+    (when (zerop (length trimmed))
+      (error 'invalid-transition :description "A launch command cannot be blank."))
+    trimmed))
+
+(defun %normalize-program-names (names)
+  "Return distinct nonblank executable names in stable alphabetical order."
+  (let ((seen (make-hash-table :test #'equal)))
+    (sort (loop for name in names
+                when (and (stringp name) (plusp (length name)) (not (gethash name seen)))
+                  collect name and do (setf (gethash name seen) t))
+          #'string-lessp)))
+
+(defun %scan-path-program-names ()
+  "Discover executable file names on PATH without making a shell typed by the user.
+
+The small POSIX probe is deliberately independent of dmenu: Lime needs the
+same ordinary executable catalog even when dmenu is not installed. Its output
+becomes inert cached data, never code. Actual launching uses an argument vector in
+BACKEND-LAUNCH-PROGRAM, never interpolated shell text."
+  (handler-case
+      (%normalize-program-names
+       (uiop:split-string
+        (uiop:run-program
+         (list "/bin/sh" "-c"
+               "IFS=:
+for directory in $PATH; do
+  for program in \"$directory\"/*; do
+    [ -f \"$program\" ] && [ -x \"$program\" ] && printf '%s\\n' \"${program##*/}\"
+  done
+done")
+         :output :string :ignore-error-status t)
+        :separator '(#\Newline #\Return)))
+    (error ()
+      ;; A missing/broken PATH should leave the picker empty and explain the
+      ;; situation through its ordinary "no matching program" state, not take
+      ;; down the X event loop.
+      '())))
+
+(defvar *path-program-cache* nil
+  "Process-local executable catalog; never persisted into the user's session.")
+
+(defun %path-program-signature ()
+  "Cheap invalidation for PATH edits and installed/removed/renamed programs."
+  (let ((path (or (uiop:getenv "PATH") "")))
+    (list path (namestring (uiop:getcwd))
+          (loop for directory in (uiop:split-string path :separator '(#\:))
+                collect (ignore-errors
+                          (file-write-date
+                           (uiop:ensure-directory-pathname
+                            (if (zerop (length directory)) "." directory))))))))
+
+(defun %path-program-names (&key refresh-p)
+  "Reuse executable names while PATH and its directories are unchanged.
+
+Directory dates detect ordinary installs/removals. Also refresh after five
+minutes on the next open to catch permission-only edits and coarse timestamps.
+REFRESH-P forces immediate discovery for callers editing executable scripts."
+  (let ((signature (%path-program-signature))
+        (now (get-internal-real-time)))
+    (unless (and (not refresh-p) *path-program-cache*
+                 (equal signature (getf *path-program-cache* :signature))
+                 (< (- now (getf *path-program-cache* :time))
+                    (* 300 internal-time-units-per-second)))
+      (setf *path-program-cache*
+            (list :signature signature :time now :programs (%scan-path-program-names))))
+    ;; Sessions/callers may rearrange their list, but not the cached catalog.
+    (copy-list (getf *path-program-cache* :programs))))
+
+(declaim (ftype function %cursor-session-launch-argv))
+(defun backend-launch-program (backend argv)
+  "Launch an argument-vector ARGV in Lime's inherited X session environment.
+
+ARGV is deliberately an argument list, not shell text. The new top-level
+window will arrive through the normal MapRequest path and join the selected
+Head's live Presentation like any external client. The configured cursor theme
+is passed to this child without changing the process-wide environment. No
+Activity/View policy is hidden in the launcher itself."
+  (unless (and (consp argv)
+               (every #'stringp argv)
+               (not (zerop (length (first argv)))))
+    (error 'invalid-transition
+           :description "A program launch needs a non-empty list of string arguments."))
+  (uiop:launch-program (%cursor-session-launch-argv backend argv)
+                       :output :interactive :error-output :interactive))
+
+(defun backend-launch-shell-command (backend command)
+  "Run COMMAND through /bin/sh -c in Lime's inherited session environment.
+
+This is the dmenu_run-like escape hatch for a user who explicitly typed a
+command into Lime's palette. Configured commands should normally prefer
+BACKEND-LAUNCH-PROGRAM with a fixed argument vector."
+  (backend-launch-program backend
+                          (list "/bin/sh" "-c" (%nonblank-launch-command command))))
+
+(defun backend-launch-terminal (backend)
+  "Launch the user's current dwm terminal default, st."
+  (backend-launch-program backend '("st")))
+
+(defun %lime-browser-profile-directory ()
+  "Return Lime's persistent, separate Waterfox profile directory.
+
+Two concurrent Waterfox processes cannot safely use the same profile.  A Lime
+test session commonly runs beside an existing desktop session, so use a small
+dedicated profile under the XDG state home instead of showing Waterfox's
+profile-lock dialog or forwarding a window to another DISPLAY."
+  (let* ((state-home
+           (uiop:ensure-directory-pathname
+            (or (uiop:getenv "XDG_STATE_HOME")
+                (merge-pathnames #P".local/state/" (user-homedir-pathname)))))
+         (profile-directory
+           (merge-pathnames #P"lime/waterfox-profile/" state-home)))
+    ;; ENSURE-DIRECTORIES-EXIST takes a prospective file pathname.  The
+    ;; sentinel is never created; it simply ensures the full profile path is
+    ;; available before Waterfox initializes its own profile files.
+    (ensure-directories-exist (merge-pathnames #P".profile-directory-ready"
+                                                profile-directory))
+    (namestring profile-directory)))
+
+(defun backend-launch-browser (backend &key test-profile-p)
+  "Launch Waterfox normally, letting it select the user's usual profile.
+
+TEST-PROFILE-P explicitly opts into an isolated profile for a concurrent
+nested-X session. Never silently substitute that profile on a real desktop:
+doing so makes the user's tabs, extensions, and theme appear to be missing."
+  (backend-launch-program
+   backend
+   (if test-profile-p
+       (list "waterfox" "--new-instance" "--profile"
+             (%lime-browser-profile-directory))
+       '("waterfox"))))

src/x11/lifecycle.lisp

@@ -0,0 +1,178 @@
+(in-package #:lime.x11)
+
+;;;; Client lifecycle normalization
+;;;
+;;; X11 events answer "what happened to this client?"  They do not choose an
+;;; Activity, View, layout, or collision policy.  This module translates that
+;;; narrow lifecycle information into model commands, then asks rendering to
+;;; reconcile the resulting state.
+
+;; Configuration is deliberately loaded after lifecycle so a configuration
+;; file can depend on the complete adapter command surface.  These functions
+;; are defined there but are only called after the complete system loads.
+(declaim (ftype (function (t) t) configured-new-client-focus-p)
+         (ftype (function (t t) t)
+                configured-new-tiled-client-position
+                configured-close-focus-direction))
+(declaim (ftype function %session-note-client %session-forget-client))
+
+(defun manage-window (backend window)
+  "Adopt a MapRequest into a task draft or map an external EWMH surface.
+
+Dock and desktop windows are real EWMH clients but not user task windows, so
+they retain application geometry outside Activities, Views, and leases."
+  (unless (or (= (xlib:window-id window) (xlib:window-id (x11-backend-root backend)))
+              (eq (xlib:window-override-redirect window) :on))
+    (let ((window-types (%ewmh-window-types-for-window backend window)))
+      (if (%ewmh-external-window-types-p window-types)
+          (ewmh-adopt-external-window backend window window-types)
+          (let* ((world (x11-backend-world backend))
+                 (client-id (or (%backend-client-id backend window)
+                                (%client-id-for-window window))))
+            (%register-window backend client-id window)
+            (%session-note-client backend client-id window)
+            (icccm-adopt-client backend client-id window)
+            (ewmh-adopt-client backend client-id window)
+            (let ((decision (new-client-placement-decision backend client-id window)))
+              (handler-case
+                  (find-client world client-id)
+                (unknown-entity ()
+                  ;; A normal window follows the selected Presentation. A managed
+                  ;; transient deliberately follows its parent's Presentation and
+                  ;; Activity, even when another Head is currently selected.
+                  (create-client world client-id
+                                 (x11-placement-decision-activity-id decision)
+                                 :name client-id)))
+              (pointer-adopt-client backend window)
+              (let* ((presentation
+                       (find-presentation
+                        world (x11-placement-decision-presentation-id decision)))
+                     (layout-mode (presentation-layout-mode presentation))
+                     (focus-p (or (x11-placement-decision-focus-p decision)
+                                  (configured-new-client-focus-p backend))))
+                (show-client-on-presentation
+                 world client-id (x11-placement-decision-presentation-id decision)
+                 :kind (x11-placement-decision-kind decision)
+                 :data (x11-placement-decision-data decision)
+                 :tiled-insertion-position
+                 (if (eq (x11-placement-decision-kind decision) :tile)
+                     (configured-new-tiled-client-position backend layout-mode)
+                     :back)
+                 :focus-p focus-p)
+                (cond
+                  ;; Some games publish their desired state before MapRequest instead
+                  ;; of sending a later client message. Honor that initial request
+                  ;; through the same command used by EWMH events.
+                  ((ewmh-window-requests-fullscreen-p backend window)
+                   (backend-set-client-fullscreen backend client-id t))
+                  (focus-p
+                   ;; Both regular newly managed clients and transient/dialog
+                   ;; surfaces use the same focus policy; the latter simply
+                   ;; force it on even in a no-focus-on-new-client config.
+                   (backend-focus-client backend client-id
+                                         :head-id (x11-placement-decision-head-id decision)))
+                  (t (apply-active-presentation backend))))
+              client-id))))))
+
+(defun %handle-configure-request
+    (backend window x y width height border-width value-mask
+     &optional parent above-sibling)
+  ;; Lime retains geometry authority for both tiles and floats. The renderer
+  ;; now applies cached WM_NORMAL_HINTS before restoring that geometry, then
+  ;; a synthetic ConfigureNotify tells the client exactly what it received.
+  ;; EWMH docks/desktops are intentionally the sole exception: those are not
+  ;; Activity clients and retain their application-owned geometry.
+  ;; PARENT and ABOVE-SIBLING complete the ConfigureRequest contract.  Lime
+  ;; has no stacking policy for normal client requests yet, so they are
+  ;; deliberately retained by the adapter but not acted upon.
+  (declare (ignore parent above-sibling))
+  (if (ewmh-handle-external-configure-request
+       backend window x y width height border-width value-mask)
+      (xlib:display-force-output (x11-backend-display backend))
+      (when (%registered-window-p backend window)
+        (apply-active-presentation backend)
+        (icccm-send-configure-notify window)
+        (xlib:display-force-output (x11-backend-display backend))))
+  nil)
+
+(defun %retire-managed-client (backend client-id &key window-id)
+  "Remove a gone CLIENT-ID from backend caches and every core container."
+  (when client-id
+    (%session-forget-client backend client-id)
+    (remhash client-id (x11-backend-original-border-widths backend))
+    (pointer-forget-client backend client-id)
+    (icccm-forget-client backend client-id)
+    (ewmh-forget-client backend client-id :window-id window-id)
+    ;; Adoption can lose a window during its initial property queries, before
+    ;; it has a core client. Adapter cleanup must still be complete/idempotent.
+    (when (handler-case (find-client (x11-backend-world backend) client-id)
+            (unknown-entity () nil))
+      (retire-client
+       (x11-backend-world backend) client-id
+       :focus-direction
+       (lambda (container)
+         (configured-close-focus-direction
+          backend
+          (typecase container
+            (presentation (presentation-layout-mode container))
+            (view (view-layout-mode container))))))))
+  client-id)
+
+(defun %handle-destroy-notify (backend window)
+  "Retire a permanently destroyed X11 client before reconciling survivors."
+  (let ((client-id (%forget-window backend window)))
+    (when client-id
+      (%forget-pending-unmaps backend window)
+      (%retire-managed-client backend client-id :window-id (xlib:window-id window))
+      (apply-active-presentation backend))
+    (unless client-id
+      (ewmh-forget-external-window backend window)))
+  nil)
+
+(defun %handle-unmap-notify (backend event-window window configure-p)
+  "Distinguish Lime's View hides from an application's ICCCM withdrawal.
+
+The root receives both kinds because it selected :SUBSTRUCTURE-NOTIFY.  A
+renderer token identifies our own unmap.  Parent-resize unmaps are not client
+withdrawals, and an unknown window is already outside Lime's ownership."
+  (let ((client-id (%backend-client-id backend window)))
+    (cond
+      ((null client-id)
+       (ewmh-forget-external-window backend window)
+       nil)
+      ((%consume-pending-unmap-p backend window) nil)
+      ((or configure-p
+           ;; The root is the ordinary event recipient.  Keep this guard so
+           ;; a future per-window event subscription cannot accidentally turn
+           ;; a hierarchy detail into a task-client retirement.
+           ;; CLX may recreate a wrapper after QueryTree/InputFocus lookups;
+           ;; protocol identity is the XID, not Lisp object identity.
+           (/= (xlib:window-id event-window)
+               (xlib:window-id (x11-backend-root backend))))
+       nil)
+      (t
+       ;; ICCCM withdrawal means the application removed itself.  It is not a
+       ;; hidden member of a View, so retire it just like DestroyNotify.
+       (icccm-withdraw-client backend client-id window)
+       (%restore-client-border backend client-id window)
+       (%forget-window backend window)
+       (%retire-managed-client backend client-id :window-id (xlib:window-id window))
+       (apply-active-presentation backend))))
+  nil)
+
+(defun %handle-property-notify (backend window atom)
+  "Refresh metadata; repaint titles without reapplying client geometry."
+  (let ((client-id (%backend-client-id backend window)))
+    (when client-id
+      (icccm-handle-property-notify backend client-id window atom)
+      (ewmh-handle-property-notify backend client-id window atom)
+      (when (member atom '(:WM_HINTS :_NET_WM_STATE))
+        (%attention-refresh-client backend client-id window)
+        (%attention-acknowledge-client backend client-id))
+      ;; A property update stays entirely adapter-local, but changed hints
+      ;; should take effect before the next user action or ConfigureRequest.
+      (cond
+        ((eq atom :WM_NORMAL_HINTS) (apply-active-presentation backend))
+        ((member atom '(:_NET_WM_NAME :WM_NAME :WM_CLASS :WM_HINTS :_NET_WM_STATE))
+         (render-head-bars backend)))))
+  nil)

src/x11/navigation.lisp

@@ -0,0 +1,234 @@
+(in-package #:lime.x11)
+
+;;;; Ordered Activity shortcuts, stable View slots, and Head-local history.
+;;;; These are adapter
+;;;; navigation metadata, never Activity/View identities or layout state.
+
+(defstruct navigation-state
+  (activities nil) (views nil) (resume nil)
+  observed-world observed-revision (generation 0))
+
+;; A separately owned runtime lets navigation evolve without redefining the
+;; live backend's structure. STOP-BACKEND releases it on every implementation.
+(defvar *backend-navigation-states*
+  (make-hash-table :test #'eq #+sbcl :weakness #+sbcl :key))
+
+(declaim (ftype function %forget-activity-navigation-state %portable-activity-presentation))
+
+(defun %forget-navigation-state (backend)
+  (remhash backend *backend-navigation-states*)
+  (%forget-activity-navigation-state backend))
+
+(defun %navigation-slots (existing ids)
+  "Keep surviving assignments; fill holes for new ids without shifting peers."
+  (let ((result (remove-if-not (lambda (row) (member (first row) ids :test #'equal)) existing)))
+    (dolist (id ids)
+      (unless (assoc id result :test #'equal)
+        (push (list id (loop for slot from 1
+                            unless (find slot result :key #'second) return slot)) result)))
+    (sort (copy-list result) #'< :key #'second)))
+
+(defun %navigation-activity-slots (existing ids)
+  "Keep the surviving bar order, close gaps, and append previously unseen ids.
+
+Always allocate fresh rows: synchronization must not mutate persisted input or
+an earlier navigation snapshot. View slots deliberately use the stable policy."
+  (let* ((survivors (sort (copy-list (remove-if-not (lambda (row) (member (first row) ids :test #'equal)) existing))
+                          #'< :key #'second))
+         (ordered-ids (append (mapcar #'first survivors)
+                              (remove-if (lambda (id) (assoc id survivors :test #'equal)) ids))))
+    (loop for id in ordered-ids for slot from 1 collect (list id slot))))
+
+(defun %navigation-state (backend)
+  "Synchronize tiny navigation indexes, at most once per model revision."
+  (let* ((state (or (gethash backend *backend-navigation-states*)
+                    (setf (gethash backend *backend-navigation-states*) (make-navigation-state))))
+         (world (x11-backend-world backend)))
+    (unless (and (eq world (navigation-state-observed-world state))
+                 (eql (world-revision world) (navigation-state-observed-revision state)))
+      (let* ((activities
+               (sort (list-activities world) #'string<
+                     :key (lambda (a)
+                            ;; A predictable migration for desks with no slots.
+                            (if (equal "scratch" (activity-id a)) ""
+                                (format nil "~A ~S" (string-downcase (activity-name a)) (activity-id a))))))
+             (activity-slots (%navigation-activity-slots (navigation-state-activities state)
+                                                (mapcar #'activity-id activities)))
+             (view-slots
+               (loop for a in activities append
+                     (%navigation-slots
+                      (remove-if-not (lambda (row) (member (first row) (activity-view-ids a) :test #'equal))
+                                     (navigation-state-views state))
+                      (activity-view-ids a))))
+             (resume
+               (remove-if-not
+                (lambda (row)
+                  (let ((p (gethash (third row) (lime.core::world-presentations world))))
+                    (and p (equal (first row) (presentation-head-id p))
+                         (equal (second row) (presentation-activity-id p)))))
+                (navigation-state-resume state))))
+        ;; Record all active Heads, not just the selected one. Previously
+        ;; rendered presentations remain in history when another takes over.
+        (dolist (head-id (backend-head-ids backend))
+          (let ((p (current-presentation world head-id)))
+            (when p
+              (setf resume
+                    (cons (list head-id (presentation-activity-id p) (presentation-id p))
+                          (remove-if (lambda (row) (and (equal head-id (first row))
+                                                        (equal (presentation-activity-id p) (second row))))
+                                     resume))))))
+        (unless (and (equal activity-slots (navigation-state-activities state))
+                     (equal view-slots (navigation-state-views state))
+                     (equal resume (navigation-state-resume state)))
+          (incf (navigation-state-generation state)))
+        (setf (navigation-state-activities state) activity-slots
+              (navigation-state-views state) view-slots
+              (navigation-state-resume state) resume
+              (navigation-state-observed-world state) world
+              (navigation-state-observed-revision state) (world-revision world))))
+    state))
+
+(defun backend-activity-slot (backend activity-id)
+  (second (assoc activity-id (navigation-state-activities (%navigation-state backend)) :test #'equal)))
+
+(defun backend-view-slot (backend view-id)
+  (second (assoc view-id (navigation-state-views (%navigation-state backend)) :test #'equal)))
+
+(defun %assign-navigation-slot (rows id slot)
+  (unless (typep slot '(integer 1 *))
+    (error 'invalid-transition :description "A navigation slot must be a positive integer."))
+  (let* ((result (copy-tree rows)) (target (assoc id result :test #'equal))
+         (occupant (find slot result :key #'second)))
+    (unless target (error 'invalid-transition :description "No navigation target with that id."))
+    (when occupant (setf (second occupant) (second target)))
+    (setf (second target) slot)
+    (sort result #'< :key #'second)))
+
+(defun backend-set-activity-slot (backend activity-id slot)
+  "Swap with bar position SLOT (1 through the Activity count). No window moves."
+  (find-activity (x11-backend-world backend) activity-id)
+  (let ((state (%navigation-state backend)))
+    (unless (and (typep slot '(integer 1 *))
+                 (<= slot (length (navigation-state-activities state))))
+      (error 'invalid-transition :description "An Activity position must be between 1 and the Activity count."))
+    (setf (navigation-state-activities state)
+          (%assign-navigation-slot (navigation-state-activities state) activity-id slot))
+    (incf (navigation-state-generation state)))
+  (when (x11-backend-display backend) (render-head-bars backend))
+  slot)
+
+(defun backend-set-view-slot (backend view-id slot)
+  "Assign a slot local to the View's Activity; swap only within that Activity."
+  (let* ((world (x11-backend-world backend)) (view (find-view world view-id))
+         (ids (activity-view-ids (find-activity world (view-activity-id view))))
+         (state (%navigation-state backend)))
+    (setf (navigation-state-views state)
+          (append (%assign-navigation-slot
+                   (remove-if-not (lambda (row) (member (first row) ids :test #'equal))
+                                  (navigation-state-views state)) view-id slot)
+                  (remove-if (lambda (row) (member (first row) ids :test #'equal))
+                             (navigation-state-views state))))
+    (incf (navigation-state-generation state)))
+  (when (x11-backend-display backend) (render-head-bars backend))
+  slot)
+
+(defun backend-navigation-slots (backend)
+  "Return independent lists of (id slot), with Views numbered per Activity."
+  (let ((state (%navigation-state backend)))
+    (copy-tree (list :activities (navigation-state-activities state)
+                     :views (navigation-state-views state)))))
+
+(defun %navigation-snapshot (backend)
+  (let ((state (%navigation-state backend)))
+    (lime.persistence:copy-data
+     (list :activities (navigation-state-activities state)
+           :views (navigation-state-views state) :resume (navigation-state-resume state)))))
+
+(defun %navigation-read-data (data world)
+  "Validate persisted navigation independently before replacing any live state."
+  (lime.persistence:check-data data)
+  (lime.persistence:check-record data '(:activities :views :resume))
+  (dolist (key '(:activities :views))
+    (let ((ids nil) (slots nil))
+      (dolist (row (getf data key))
+        (unless (and (listp row) (= 2 (length row)) (typep (second row) '(integer 1 *)))
+          (error "Malformed navigation slot."))
+        (let* ((id (first row))
+               (scope (if (eq key :activities)
+                          (progn (find-activity world id) :activities)
+                          (view-activity-id (find-view world id))))
+               (slot (list scope (second row))))
+          (when (or (member id ids :test #'equal) (member slot slots :test #'equal))
+            (error "Duplicate navigation id or slot."))
+          (push id ids) (push slot slots)))))
+  (let ((seen nil))
+    (dolist (row (getf data :resume))
+      (unless (and (listp row) (= 3 (length row))) (error "Malformed navigation resume entry."))
+      (let ((p (find-presentation world (third row))) (key (subseq row 0 2)))
+        (unless (and (equal (first row) (presentation-head-id p))
+                     (equal (second row) (presentation-activity-id p))
+                     (not (member key seen :test #'equal)))
+          (error "Invalid navigation resume target."))
+        (push key seen))))
+  ;; Accept older sparse assignments, but preserve only their ordering. Do
+  ;; this after validation so compaction cannot mask duplicate/corrupt slots.
+  (make-navigation-state :activities (%navigation-activity-slots
+                                     (getf data :activities)
+                                     (mapcar #'first (getf data :activities)))
+                         :views (copy-tree (getf data :views)) :resume (copy-tree (getf data :resume))))
+
+(defun %navigation-resume-target (backend activity-id head-id)
+  ;; History is retained for old-session migration, not as another source of
+  ;; working state. There is exactly one current arrangement for this pair.
+  (let ((p (activity-draft-for-head (x11-backend-world backend) activity-id head-id)))
+    (and p (presentation-id p))))
+
+(defun backend-preflight-activity-switch (backend activity-id &key (head-id (x11-backend-focused-head-id backend)))
+  "Inspect resuming the last live arrangement, not reloading its checkpoint."
+  (%head-for-id backend head-id)
+  (find-activity (x11-backend-world backend) activity-id)
+  (let ((portable (%portable-activity-presentation backend activity-id)))
+    (if portable
+        (preflight-presentation-bring (x11-backend-world backend) head-id (presentation-id portable))
+        (preflight-activity-draft (x11-backend-world backend) head-id activity-id
+                                 :default-layout (configured-default-layout backend)))))
+
+(defun backend-switch-to-activity (backend activity-id &key (head-id (x11-backend-focused-head-id backend)) (policy :strict))
+  "Bring a portable Activity here, or resume this Head's extended portion."
+  (unless (member policy '(:strict :partial :take))
+    (error 'invalid-transition :description "Activity policy must be :STRICT, :PARTIAL, or :TAKE."))
+  (let* ((world (x11-backend-world backend)) (current (current-presentation world head-id))
+         (portable (%portable-activity-presentation backend activity-id))
+         (target (%navigation-resume-target backend activity-id head-id)))
+    (%head-for-id backend head-id)
+    (find-activity world activity-id)
+    (cond ((and portable (eq portable current)) current)
+          (portable (%apply-command-result backend
+                    (bring-presentation-to-head world (presentation-id portable) head-id)))
+          ((and current (equal activity-id (presentation-activity-id current))) current)
+          (target (%apply-command-result backend (%resume-presentation-with-policy world head-id target policy)))
+          (t (%apply-command-result backend
+              (open-activity-draft world head-id activity-id :policy policy
+                                   :default-layout (configured-default-layout backend)))))))
+
+(declaim (ftype function %ui-request-activity-activation %ui-request-view-activation %open-ui-session))
+
+(defun %show-navigation-result (backend result)
+  ;; Successful requests never open a menu. Only conflicts need interaction.
+  (unless (eq :close (ui-result-kind result))
+    (%open-ui-session backend (make-ui-session (ui-result-candidates result)
+                                               :status (ui-result-message result))))
+  result)
+
+(defun backend-select-activity-slot (backend slot)
+  "Select numbered Activity on the focused Head; an empty slot is a no-op."
+  (let ((id (first (find slot (navigation-state-activities (%navigation-state backend)) :key #'second))))
+    (when id (%show-navigation-result backend (%ui-request-activity-activation backend id)))))
+
+(defun backend-select-view-slot (backend slot)
+  "Recall a numbered View local to the focused Activity; current View is a no-op."
+  (let* ((p (current-presentation (x11-backend-world backend) (x11-backend-focused-head-id backend)))
+         (ids (and p (activity-view-ids (find-activity (x11-backend-world backend) (presentation-activity-id p)))))
+         (id (first (find-if (lambda (row) (and (= slot (second row)) (member (first row) ids :test #'equal)))
+                             (navigation-state-views (%navigation-state backend))))))
+    (when id (%show-navigation-result backend (%ui-request-view-activation backend id)))))

src/x11/package.lisp

@@ -0,0 +1,316 @@
+(defpackage #:lime.x11
+  (:use #:cl #:lime.core #:lime.ui)
+  (:documentation
+   "The small CLX bridge that renders Lime's pure model on one X11 screen.")
+  (:export
+   #:backend-open-activity-picker
+   #:backend-activity-slot
+   #:backend-view-slot
+   #:backend-navigation-slots
+   #:backend-set-activity-slot
+   #:backend-set-view-slot
+   #:backend-select-activity-slot
+   #:backend-select-view-slot
+   #:backend-switch-to-activity
+   #:backend-activity-navigation-mode
+   #:backend-extend-activity-to-head
+   #:backend-make-activity-portable
+   #:backend-preflight-activity-switch
+   #:x11-backend
+   #:x11-backend-world
+   #:x11-backend-head-id
+   #:x11-backend-activity-id
+   #:x11-backend-focused-head-id
+   #:x11-backend-configuration
+   #:x11-backend-configuration-source
+   #:x11-backend-configuration-name
+   #:x11-head
+   #:make-x11-head
+   #:x11-head-head-id
+   #:x11-head-x
+   #:x11-head-y
+   #:x11-head-width
+   #:x11-head-height
+   #:x11-head-output-id
+   #:x11-head-output-ids
+   #:x11-head-output-name
+   #:x11-work-area
+   #:make-x11-work-area
+   #:x11-work-area-x
+   #:x11-work-area-y
+   #:x11-work-area-width
+   #:x11-work-area-height
+   #:x11-head-work-area
+   #:start-backend
+   #:stop-backend
+   #:run-event-loop
+   #:run-demo
+   #:manage-window
+   ;; Diagnostics and explicit recovery (not session persistence).
+   #:backend-diagnostics
+   #:backend-record-diagnostic
+   #:backend-release-input
+   #:backend-reconcile-after-error
+   #:backend-save-session
+   #:backend-session-status
+   ;; ICCCM client facts.
+   #:icccm-client-info
+   #:icccm-client-info-client-id
+   #:icccm-client-info-window-id
+   #:icccm-client-info-title
+   #:icccm-client-info-resource-name
+   #:icccm-client-info-resource-class
+   #:icccm-client-info-protocols
+   #:icccm-client-info-accepts-input-p
+   #:icccm-client-info-delete-window-p
+   #:icccm-client-info-take-focus-p
+   #:icccm-client-info-transient-for-client-id
+   #:icccm-client-info-normal-hints
+   #:icccm-client-info-wm-state
+   #:backend-client-icccm-info
+   #:icccm-wm-state-data
+   ;; EWMH metadata that may be useful to a later UI or rule layer.
+   #:ewmh-client-window-types
+   ;; Declarative rendering seam.
+   #:x11-effect
+   #:make-x11-effect
+   #:x11-effect-kind
+   #:x11-effect-client-id
+   #:x11-effect-geometry
+   #:x11-effect-border-width
+   #:x11-effect-border-color
+   #:window-appearance
+   #:make-window-appearance
+   #:window-appearance-border-width
+   #:window-appearance-focused-border
+   #:window-appearance-unfocused-border
+   #:window-appearance-inner-gap
+   #:window-appearance-outer-gap
+   #:x11-render-plan
+   #:make-x11-render-plan
+   #:x11-render-plan-world-revision
+   #:x11-render-plan-effects
+   #:build-render-plan
+   #:execute-render-plan
+   #:apply-active-presentation
+   ;; REPL-friendly command surface.
+   #:backend-status
+   #:backend-request-quit
+   #:backend-head-ids
+   #:backend-randr-status
+   #:backend-randr-topology-report
+   #:backend-build-randr-topology-plan
+   #:backend-apply-randr-topology-plan
+   #:backend-reconcile-randr-heads
+   #:backend-refresh-randr-heads
+   #:backend-select-head
+   #:backend-select-relative-head
+   #:backend-start-activity
+   #:backend-delete-activity
+   #:backend-start-named-activity
+   #:backend-activate-activity
+   #:backend-preflight-activity-activation
+   #:backend-save-view
+   #:backend-save-named-view
+   #:backend-save-viewset
+   #:backend-save-named-viewset
+   #:backend-update-view
+   #:backend-update-current-view
+   #:backend-preflight-view-activation
+   #:backend-activate-view
+   #:backend-activate-view-strictly
+   #:backend-activate-view-partially
+   #:backend-activate-view-taking
+   #:backend-preflight-viewset-activation
+   #:backend-activate-viewset
+   #:backend-activate-viewset-strictly
+   #:backend-activate-viewset-partially
+   #:backend-activate-viewset-taking
+   #:backend-resume-presentation
+   #:backend-set-layout-root
+   #:backend-use-master-stack-layout
+   #:backend-use-monocle-layout
+   #:backend-use-manual-layout
+   #:backend-adjust-master-stack-ratio
+   #:backend-adjust-master-stack-count
+   #:backend-set-focused-tile-weight
+   #:backend-adjust-focused-tile-weight
+   #:backend-cycle-layout
+   #:backend-promote-focused-client
+   #:backend-focus-master-client
+   #:backend-orient-focused-split
+   #:backend-resize-focused-split
+   #:backend-swap-focused-client
+   #:backend-toggle-client-floating
+   #:backend-toggle-focused-client-floating
+   #:backend-set-client-floating-geometry
+   #:backend-hide-client
+   #:backend-hide-focused-client
+   #:backend-show-client
+   #:backend-show-client-taking
+   #:backend-move-client-to-activity
+   #:backend-set-client-shared
+   #:backend-make-client-private
+   #:backend-focus-client
+   #:backend-focus-next-client
+   #:backend-focus-previous-client
+   #:backend-focus-head-background
+   #:backend-transfer-focused-client-to-head
+   #:backend-transfer-focused-client-relatively
+   #:backend-rehome-client-to-head
+   #:backend-set-client-fullscreen
+   #:backend-toggle-focused-client-fullscreen
+   #:backend-close-client
+   #:backend-close-focused-client
+   ;; Process launch boundary: generic shell entry plus the starter commands
+   ;; matching the user's existing dwm setup.
+   #:backend-launch-program
+   #:backend-launch-shell-command
+   #:backend-launch-terminal
+   #:backend-launch-browser
+   ;; Opt-in input bindings.
+   #:keybinding
+   #:keybinding-key
+   #:keybinding-modifiers
+   #:keybinding-description
+   #:bind-key
+   #:unbind-key
+   #:clear-keybindings
+   #:list-keybindings
+   #:backend-last-command-error
+   ;; User configuration and its first-class command registry.  The pleasant
+   ;; DEFCONFIGURATION surface itself lives in the LIME.CONFIG package.
+   #:lime-command
+   #:make-lime-command
+   #:lime-command-id
+   #:lime-command-label
+   #:lime-command-description
+   #:lime-command-category
+   #:lime-command-key
+   #:lime-command-action
+   #:lime-configuration
+   #:make-lime-configuration
+   #:lime-configuration-default-keybindings-p
+   #:lime-configuration-default-modifiers
+   #:lime-configuration-default-layout
+   #:lime-configuration-new-client-focus-p
+   #:lime-configuration-new-tiled-client-position
+   #:lime-configuration-close-focus-direction
+   #:lime-configuration-layout-client-flow-policies
+   #:layout-client-flow-policy
+   #:make-layout-client-flow-policy
+   #:layout-client-flow-policy-layout-mode
+   #:layout-client-flow-policy-new-tiled-client-position
+   #:layout-client-flow-policy-close-focus-direction
+   #:lime-configuration-commands
+   #:lime-configuration-bindings
+   #:lime-configuration-rules
+   #:lime-configuration-appearance
+   #:lime-configuration-bar-style
+   #:lime-configuration-font
+   #:lime-configuration-cursor
+   #:ui-cursor-style
+   #:make-ui-cursor-style
+   #:ui-cursor-style-theme
+   #:ui-cursor-style-size
+   #:backend-cursor-report
+   #:ui-font-style
+   #:make-ui-font-style
+   #:ui-font-style-family
+   #:ui-font-style-size
+   #:ui-font-style-weight
+   #:lime-configuration-bar-height
+   #:lime-configuration-bar-height-supplied-p
+   #:lime-configuration-status-providers
+   #:lime-configuration-status-providers-supplied-p
+   #:lime-configuration-startup-hooks
+   #:configuration-binding
+   #:make-configuration-binding
+   #:configuration-binding-key
+   #:configuration-binding-modifiers
+   #:configuration-binding-command-id
+   #:configuration-binding-description
+   #:window-rule
+   #:make-window-rule
+   #:window-rule-id
+   #:window-rule-resource-name
+   #:window-rule-resource-class
+   #:window-rule-title
+   #:window-rule-predicate
+   #:window-rule-float-p
+   #:window-rule-center-p
+   #:register-lime-configuration
+   #:find-lime-configuration
+   #:load-lime-configuration
+   #:apply-lime-configuration
+   #:configure-backend-from-file
+   #:reload-backend-configuration
+   #:start-lime
+   #:list-configured-commands
+   #:find-configured-command
+   #:run-configured-command
+   ;; First UI surface: a Head-local command palette.
+   #:backend-open-command-palette
+   #:backend-open-run-prompt
+   #:backend-open-hidden-client-picker
+   #:backend-open-view-update-picker
+   #:backend-send-focused-client-to-head
+   #:backend-send-focused-client-relatively
+   #:backend-close-command-palette
+   #:backend-command-palette-open-p
+   ;; Reusable Head bar and optional right-side status providers.
+   #:head-bar-style
+   #:make-head-bar-style
+   #:head-bar-style-padding-x
+   #:head-bar-style-background
+   #:head-bar-style-foreground
+   #:head-bar-style-focused-background
+   #:head-bar-style-focused-foreground
+   #:head-bar-style-unfocused-background
+   #:head-bar-style-unfocused-foreground
+   #:head-bar-style-accent-color
+   #:head-bar-style-menu-label-color
+   #:head-bar-style-logo-color
+   #:head-bar-style-separator-color
+   #:head-bar-style-attention-color
+   #:head-bar-style-attention-marker
+   #:head-bar-style-attention-indicator-p
+   #:backend-client-needs-attention-p
+   #:backend-attention-client-ids
+   #:backend-open-attention-picker
+   #:backend-attend-client
+   #:head-bar-style-title-edge-color
+   #:head-bar-segment
+   #:make-head-bar-segment
+   #:head-bar-segment-id
+   #:head-bar-segment-text
+   #:head-bar-segment-maximum-width
+   #:head-bar-segment-foreground
+   #:head-bar-segment-prefix-length
+   #:head-bar-segment-prefix-foreground
+   #:head-bar-segment-click-action
+   #:backend-set-head-bar-height
+   #:backend-set-head-bar-status-providers
+   #:status-provider
+   #:make-status-provider
+   #:status-provider-id
+   #:status-provider-formatter
+   #:status-provider-foreground
+   #:status-publish
+   #:status-wait
+   #:status-cancelled-p
+   #:backend-status-provider-report
+   #:make-clock-status-provider
+   #:make-volume-status-provider
+   #:make-music-status-provider
+   #:format-music-status
+   #:format-volume-status
+   #:format-clock-status
+   #:backend-cycle-music-source
+   #:backend-music-command
+   ;; Opt-in starter keymap and named configuration helpers.
+   #:install-default-keybindings
+   #:bind-head-key
+   #:bind-view-key
+   #:bind-viewset-key
+   #:bind-activity-key))

src/x11/persistence.lisp

@@ -0,0 +1,319 @@
+(in-package #:lime.x11)
+
+;;;; X11 identity/reconnection and owner-thread snapshot scheduling. The disk
+;;;; worker receives plain immutable data only, never the world or CLX display.
+
+(defstruct session-persistence
+  store file epoch
+  (tokens (make-hash-table :test #'equal))
+  restored-clients
+  restore-report restore-error snapshot-error (blocked-p nil) blocked-reason
+  (lock (bt:make-lock "Lime session writer"))
+  (work-ready (bt:make-condition-variable))
+  (work-done (bt:make-condition-variable))
+  thread (running-p t) pending
+  (submitted 0) (completed 0) write-error last-save-time
+  observed-signature dirty-since changed-at last-attempt)
+
+(defun %session-token ()
+  (with-open-file (stream #p"/dev/urandom" :element-type '(unsigned-byte 8))
+    (format nil "~{~2,'0X~}" (loop repeat 16 collect (read-byte stream)))))
+
+(defun %session-token-p (token)
+  (and (stringp token) (= 32 (length token))
+       (every (lambda (c) (digit-char-p c 16)) token)))
+
+(defun %read-session-token (window property)
+  (multiple-value-bind (bytes type format)
+      (xlib:get-property window property :type :STRING :end 33 :result-type 'vector)
+    (declare (ignore type))
+    (when (and bytes (eql format 8) (= 32 (length bytes)))
+      (let ((token (map 'string #'code-char bytes)))
+        (and (%session-token-p token) token)))))
+
+(defun %ensure-session-token (window property)
+  (or (%read-session-token window property)
+      (let ((token (%session-token)))
+        (xlib:change-property window property (map 'vector #'char-code token) :STRING 8)
+        token)))
+
+(defun %session-note-client (backend id window)
+  (let ((state (x11-backend-session-persistence backend)))
+    (when (and state (session-persistence-store state))
+      (setf (gethash id (session-persistence-tokens state))
+            (%ensure-session-token window :_LIME_SESSION_CLIENT)))))
+
+(defun %session-forget-client (backend id)
+  (let ((state (x11-backend-session-persistence backend)))
+    (when state (remhash id (session-persistence-tokens state)))))
+
+(defun %session-worker (state)
+  (loop
+    (let ((work
+            (bt:with-lock-held ((session-persistence-lock state))
+              (loop while (and (session-persistence-running-p state)
+                               (null (session-persistence-pending state)))
+                    do (bt:condition-wait (session-persistence-work-ready state)
+                                         (session-persistence-lock state)))
+              (when (and (null (session-persistence-pending state))
+                         (not (session-persistence-running-p state))) (return-from %session-worker))
+              (prog1 (session-persistence-pending state)
+                (setf (session-persistence-pending state) nil)))))
+      (let ((failure nil))
+        (handler-case (lime.persistence:write-session-store (session-persistence-store state) (cdr work))
+          (error (c) (setf failure (%diagnostic-condition-message c))))
+        (bt:with-lock-held ((session-persistence-lock state))
+          (setf (session-persistence-completed state) (car work)
+                (session-persistence-write-error state) failure)
+          (unless failure (setf (session-persistence-last-save-time state) (get-universal-time)))
+          (bt:condition-notify (session-persistence-work-done state)))))))
+
+(defun %validate-session-envelope (data)
+  (lime.persistence:check-record data (append '(:format :version :world :server-token :clients :focused-head :focus-root)
+                                             (when (member (getf data :version) '(2 3)) '(:navigation))
+                                             (when (eql 3 (getf data :version)) '(:activity-navigation))))
+  (unless (and (eq :lime-session (getf data :format)) (member (getf data :version) '(1 2 3))
+               (%session-token-p (getf data :server-token))
+               (member (getf data :focus-root) '(t nil)))
+    (error "Unsupported or malformed Lime session file."))
+  (let ((world (lime.persistence:restore-world (getf data :world) :normalize-arrangements-p nil))
+        (ids nil) (xids nil) (tokens nil))
+    (dolist (row (getf data :clients))
+      (lime.persistence:check-record row '(:id :xid :token :border-width))
+      (let ((id (getf row :id)) (xid (getf row :xid)) (token (getf row :token)))
+        (find-client world id)
+        (unless (and (typep xid '(integer 1 #xffffffff)) (%session-token-p token)
+                     (typep (getf row :border-width) '(integer 0 65535))
+                     (not (member id ids :test #'equal)) (not (member xid xids))
+                     (not (member token tokens :test #'equal)))
+          (error "Invalid/duplicate saved X11 client identity."))
+        (push id ids) (push xid xids) (push token tokens)))
+    (unless (= (length ids) (hash-table-count (lime.core::world-clients world)))
+      (error "Session identity list does not cover the saved client pool."))
+    (when (getf data :focused-head) (find-head world (getf data :focused-head)))
+    (let ((navigation (when (member (getf data :version) '(2 3))
+                        (%navigation-read-data (getf data :navigation) world))))
+      (when (< (getf (getf data :world) :version) 3)
+        (normalize-activity-arrangements
+         world :preferred-presentation-ids (and navigation (mapcar #'third (navigation-state-resume navigation))))
+        (when navigation
+          (setf (navigation-state-resume navigation)
+                (loop for row in (navigation-state-resume navigation)
+                      for head = (first row) for activity = (second row)
+                      for p = (activity-draft-for-head world activity head)
+                      when p collect (list head activity (presentation-id p))))))
+      (validate-world world)
+      (values world navigation
+              (if (eql 3 (getf data :version))
+                  (%activity-navigation-read-data (getf data :activity-navigation) world)
+                  ;; Infer before missing clients/topology are pruned. A reboot
+                  ;; must not erase an old Activity's genuine multi-Head intent.
+                  (make-activity-navigation-state
+                   :world world :rows (mapcar (lambda (a) (%infer-activity-navigation-row world (activity-id a)))
+                                              (list-activities world))))))))
+
+(defun %prepare-session-persistence (backend file)
+  "Restore a fully validated candidate before bootstrapping/adopting any clients."
+  (when file
+    (let* ((state (make-session-persistence))
+           (path (if (eq file :default)
+                     (lime.persistence:default-session-path (x11-backend-display-name backend)) file)))
+      (setf (x11-backend-session-persistence backend) state
+            (session-persistence-file state) (pathname path))
+      (handler-case
+          (let* ((store (setf (session-persistence-store state) (lime.persistence:open-session-store path)))
+                 (epoch (%ensure-session-token (x11-backend-root backend) :_LIME_SESSION_SERVER))
+                 (data (lime.persistence:read-session-store store)))
+            (setf (session-persistence-epoch state) epoch)
+            (when data
+              (let* ((validated (multiple-value-list (%validate-session-envelope data)))
+                     (world (first validated))
+                     (navigation (second validated))
+                     (activity-navigation (third validated))
+                     (same-server (equal epoch (getf data :server-token)))
+                     (children (xlib:query-tree (x11-backend-root backend)))
+                     (matched nil) (missing nil))
+                (dolist (row (getf data :clients))
+                  (let ((window (and same-server (find (getf row :xid) children :key #'xlib:window-id))))
+                    ;; Never reconnect by title, class, PID, or XID alone. Also
+                    ;; reject withdrawn/unmanaged windows, including stale tags.
+                    (if (and window
+                             (handler-case
+                                 (and (not (eq :on (xlib:window-override-redirect window)))
+                                      (equal (getf row :token) (%read-session-token window :_LIME_SESSION_CLIENT))
+                                      (or (eq :viewable (xlib:window-map-state window))
+                                          (member (first (xlib:get-property window :WM_STATE :type :WM_STATE)) '(1 3))))
+                               (x11-client-disappeared () nil)))
+                        (push (cons row window) matched)
+                        (progn (push (getf row :id) missing) (retire-client world (getf row :id))))))
+                ;; Removed Heads keep suspended drafts. No guessed move onto a
+                ;; different monitor, and no leases remain on absent hardware.
+                (let ((plan (build-head-topology-reconciliation-plan
+                             (preflight-head-topology-reconciliation world (backend-head-ids backend)))))
+                  (commit-head-topology-reconciliation-plan world plan))
+                (validate-world world)
+                (setf (x11-backend-world backend) world
+                      (session-persistence-restored-clients state) (reverse matched)
+                      (session-persistence-restore-report state)
+                      (list :matched (length matched) :missing (nreverse missing) :same-server-p same-server))
+                (when navigation (setf (gethash backend *backend-navigation-states*) navigation))
+                (when activity-navigation
+                  (setf (gethash backend *backend-activity-navigation-states*) activity-navigation))
+                (when (member (getf data :focused-head) (backend-head-ids backend) :test #'equal)
+                  (setf (x11-backend-focused-head-id backend) (getf data :focused-head)
+                        (x11-backend-focus-root-override-p backend) (getf data :focus-root))))))
+        (error (c)
+          ;; Keep an invalid file intact; don't silently overwrite it with a
+          ;; fresh desk. The WM can still start, with persistence blocked.
+          (setf (session-persistence-blocked-p state) t
+                (session-persistence-blocked-reason state) :restore
+                (session-persistence-restore-error state) (%diagnostic-condition-message c))
+          (backend-record-diagnostic backend c :source :session-restore)
+          (format *error-output* "~&Lime session restore disabled: ~A~%" (%diagnostic-condition-message c))))
+      (setf (session-persistence-running-p state) (not (null (session-persistence-store state))))
+      (when (session-persistence-store state)
+        (setf (session-persistence-thread state)
+              (bt:make-thread (lambda () (%session-worker state)) :name "Lime session writer"))))))
+
+(defun %adopt-session-clients (backend)
+  (let ((state (x11-backend-session-persistence backend)))
+    (when state
+      (dolist (entry (session-persistence-restored-clients state))
+        (%call-with-client-race-handling
+         backend
+         (lambda ()
+           (let* ((row (car entry)) (window (cdr entry)) (id (getf row :id)))
+             (%register-window backend id window)
+             (setf (gethash id (session-persistence-tokens state)) (getf row :token)
+                   (gethash id (x11-backend-original-border-widths backend)) (getf row :border-width))
+             (icccm-adopt-client backend id window)
+             ;; Rehydrate the visibility cache from X, not :WITHDRAWN. Hiding
+             ;; an already-unmapped restored client emits no UnmapNotify; an
+             ;; artificial pending-unmap token would swallow its later real
+             ;; withdrawal. Publish the state matching its physical mapping,
+             ;; then let the normal renderer apply the saved desk selection.
+             (icccm-set-client-state backend id window
+                                    (if (eq :viewable (xlib:window-map-state window)) :normal :iconic)
+                                    :force-p t)
+             (ewmh-adopt-client backend id window)
+             (pointer-adopt-client backend window)
+             ;; Fullscreen remains adapter state read afresh from the client.
+             (when (ewmh-window-requests-fullscreen-p backend window)
+               (setf (gethash id (x11-backend-fullscreen-clients backend)) t))))))
+      (setf (session-persistence-restored-clients state) nil))))
+
+(defun %session-signature (backend)
+  (list (world-revision (x11-backend-world backend)) (x11-backend-focused-head-id backend)
+        (x11-backend-focus-root-override-p backend)
+        (navigation-state-generation (%navigation-state backend))
+        (activity-navigation-state-generation (%activity-navigation-state backend))))
+
+(defun %session-snapshot (backend)
+  (%validate-client-registrations backend)
+  (let ((state (x11-backend-session-persistence backend)))
+    (let ((data
+            (list :format :lime-session :version 3
+                  :world (lime.persistence:snapshot-world (x11-backend-world backend))
+                  :navigation (%navigation-snapshot backend)
+                  :activity-navigation (%activity-navigation-snapshot backend)
+                  :server-token (session-persistence-epoch state)
+                  :focused-head (x11-backend-focused-head-id backend)
+                  :focus-root (x11-backend-focus-root-override-p backend)
+                  :clients (loop for id in (%registered-client-ids backend)
+                                 for window = (gethash id (x11-backend-client-windows backend))
+                                 collect (list :id id :xid (xlib:window-id window)
+                                               :token (gethash id (session-persistence-tokens state))
+                                               :border-width (gethash id (x11-backend-original-border-widths backend) 0))))))
+      ;; Validate cached/inactive drafts too; a file we write must be readable.
+      (%validate-session-envelope data)
+      (lime.persistence:copy-data data))))
+
+(defun backend-save-session (backend &key (wait-p t) replace-invalid-p)
+  "Explicitly save the current desk. Must be called on the X owner thread.
+
+REPLACE-INVALID-P authorizes overwriting a file rejected during startup. Ordinary
+autosave never does this. WAIT-P waits for disk completion and reports failures."
+  (let ((state (x11-backend-session-persistence backend)))
+    (unless (and state (session-persistence-store state) (session-persistence-running-p state))
+      (error "Session persistence is not enabled for this backend."))
+    (when (and (session-persistence-blocked-p state)
+               (eq :restore (session-persistence-blocked-reason state)) (not replace-invalid-p))
+      (error "Session autosave is blocked after a restore error; inspect BACKEND-SESSION-STATUS first."))
+    (let ((data (%session-snapshot backend)))
+      (bt:with-lock-held ((session-persistence-lock state))
+        (let ((generation (incf (session-persistence-submitted state))))
+          (setf (session-persistence-pending state) (cons generation data)
+                (session-persistence-blocked-p state) nil
+                (session-persistence-blocked-reason state) nil
+                (session-persistence-snapshot-error state) nil
+                (session-persistence-observed-signature state) (%session-signature backend)
+                (session-persistence-last-attempt state) (/ (get-internal-real-time) internal-time-units-per-second)
+                (session-persistence-dirty-since state) nil)
+          (bt:condition-notify (session-persistence-work-ready state))
+          (when wait-p
+            (loop while (< (session-persistence-completed state) generation)
+                  do (bt:condition-wait (session-persistence-work-done state) (session-persistence-lock state)))
+            (when (session-persistence-write-error state) (error "Session save failed: ~A" (session-persistence-write-error state)))))))
+    (backend-session-status backend)))
+
+(defun %poll-session-persistence (backend)
+  "Cheap change detection, with a .75s quiet period / 5s maximum dirty age."
+  (let ((state (x11-backend-session-persistence backend)))
+    (when (and state (session-persistence-store state) (not (session-persistence-blocked-p state)))
+      (let ((signature (%session-signature backend))
+            (now (/ (get-internal-real-time) internal-time-units-per-second)))
+        ;; Retry failed disk writes with backoff, even if no new edit arrives.
+        ;; Healthy unchanged sessions perform no snapshot or disk work.
+        (when (and (session-persistence-write-error state)
+                   (session-persistence-last-attempt state)
+                   (>= (- now (session-persistence-last-attempt state)) 5)
+                   (null (session-persistence-dirty-since state)))
+          (setf (session-persistence-dirty-since state) (- now 5)
+                (session-persistence-changed-at state) now))
+        (unless (equal signature (session-persistence-observed-signature state))
+          (setf (session-persistence-observed-signature state) signature
+                (session-persistence-changed-at state) now)
+          (unless (session-persistence-dirty-since state) (setf (session-persistence-dirty-since state) now)))
+        (when (and (session-persistence-dirty-since state) (not (x11-backend-pointer-drag backend))
+                   (or (>= (- now (session-persistence-changed-at state)) 3/4)
+                       (>= (- now (session-persistence-dirty-since state)) 5)))
+          (handler-case (backend-save-session backend :wait-p nil)
+            (error (c)
+              (setf (session-persistence-blocked-p state) t
+                    (session-persistence-blocked-reason state) :snapshot
+                    (session-persistence-snapshot-error state) (%diagnostic-condition-message c))
+              (backend-record-diagnostic backend c :source :session-save))))))))
+
+(defun backend-session-status (backend)
+  (let ((state (x11-backend-session-persistence backend)))
+    (if (null state) (list :enabled-p nil)
+        (bt:with-lock-held ((session-persistence-lock state))
+          (list :enabled-p (not (null (session-persistence-store state)))
+                :running-p (session-persistence-running-p state)
+                :file (if (session-persistence-store state)
+                          (lime.persistence:session-store-path (session-persistence-store state))
+                          (session-persistence-file state))
+                :blocked-p (session-persistence-blocked-p state)
+                :blocked-reason (session-persistence-blocked-reason state)
+                :restore (copy-tree (session-persistence-restore-report state))
+                :restore-error (session-persistence-restore-error state)
+                :snapshot-error (session-persistence-snapshot-error state)
+                :write-error (session-persistence-write-error state)
+                :last-save-time (session-persistence-last-save-time state)
+                :submitted (session-persistence-submitted state) :completed (session-persistence-completed state))))))
+
+(defun %stop-session-persistence (backend save-p)
+  (let ((state (x11-backend-session-persistence backend)))
+    (when (and state (session-persistence-store state) (session-persistence-running-p state))
+      (unwind-protect
+           (when (and save-p (not (session-persistence-blocked-p state)))
+             (handler-case (backend-save-session backend)
+               (error (c)
+                 (format *error-output* "~&Lime session save failed at shutdown: ~A~%"
+                         (%diagnostic-condition-message c))
+                 (error c))))
+        (bt:with-lock-held ((session-persistence-lock state))
+          (setf (session-persistence-running-p state) nil)
+          (bt:condition-notify (session-persistence-work-ready state)))
+        (when (session-persistence-thread state) (bt:join-thread (session-persistence-thread state)))
+        (lime.persistence:close-session-store (session-persistence-store state))))))

src/x11/placement-policy.lisp

@@ -0,0 +1,183 @@
+(in-package #:lime.x11)
+
+;;;; New-client placement policy
+;;;
+;;; This is intentionally an adapter policy, not a model transition. A
+;;; transient dialog still becomes an ordinary placement and lease; the policy
+;;; merely picks its initial Head, Presentation, and floating rectangle.
+
+(defstruct x11-placement-decision
+  head-id
+  presentation-id
+  activity-id
+  (kind :tile)
+  data
+  transient-for-client-id
+  ;; A transient parent and a dialog-like EWMH type both need an immediately
+  ;; usable input target after being mapped.  This is frontend placement
+  ;; policy, never saved Activity/View state.
+  (focus-p nil))
+
+(defun %active-presentation-for-client (backend client-id)
+  "Return CLIENT-ID's active leased Presentation, or NIL when it is parked."
+  (let ((lease (lease-for-client (x11-backend-world backend) client-id)))
+    (when lease
+      (let ((presentation (find-presentation
+                           (x11-backend-world backend)
+                           (lease-presentation-id lease))))
+        (and (presentation-active-p (x11-backend-world backend) presentation)
+             presentation)))))
+
+(defun %window-geometry (window)
+  (make-geometry :x (xlib:drawable-x window)
+                 :y (xlib:drawable-y window)
+                 :width (max 1 (xlib:drawable-width window))
+                 :height (max 1 (xlib:drawable-height window))))
+
+(defun %centered-over-parent-geometry (geometry parent-window)
+  (if parent-window
+      (make-geometry
+       :x (+ (xlib:drawable-x parent-window)
+             (floor (- (xlib:drawable-width parent-window)
+                       (geometry-width geometry))
+                    2))
+       :y (+ (xlib:drawable-y parent-window)
+             (floor (- (xlib:drawable-height parent-window)
+                       (geometry-height geometry))
+                    2))
+       :width (geometry-width geometry)
+       :height (geometry-height geometry))
+      geometry))
+
+(defun %floating-data-for-window (backend client-id window head parent-window)
+  "Build a canonical Head-relative float rectangle for WINDOW.
+
+The dialog's requested size is first constrained to its hints, then centered
+over its managed parent where possible. Bounds keep the final rectangle inside
+the target Head before it reaches the pure model."
+  (let* ((work-area (x11-head-work-area backend head))
+         (sized (constrain-client-geometry backend client-id
+                                           (%window-geometry window)
+                                           :work-area work-area))
+         (centered (%centered-over-parent-geometry sized parent-window))
+         (geometry (constrain-client-geometry backend client-id centered
+                                              :work-area work-area))
+         (work-width (x11-work-area-width work-area))
+         (work-height (x11-work-area-height work-area)))
+    (list :x (/ (- (geometry-x geometry) (x11-work-area-x work-area)) work-width)
+          :y (/ (- (geometry-y geometry) (x11-work-area-y work-area)) work-height)
+          :width (/ (geometry-width geometry) work-width)
+          :height (/ (geometry-height geometry) work-height))))
+
+(defun %centered-floating-data-for-window (backend client-id window head)
+  "Build a canonical centered float rectangle for an ordinary matched window.
+
+This is intentionally separate from the transient helper above.  A transient
+centers over its parent when possible; a configuration rule's `:CENTER T`
+means center inside the selected Head's ordinary work area instead."
+  (let* ((work-area (x11-head-work-area backend head))
+         (sized (constrain-client-geometry backend client-id
+                                           (%window-geometry window)
+                                           :work-area work-area))
+         (centered
+           (make-geometry
+            :x (+ (x11-work-area-x work-area)
+                  (floor (- (x11-work-area-width work-area)
+                            (geometry-width sized))
+                         2))
+            :y (+ (x11-work-area-y work-area)
+                  (floor (- (x11-work-area-height work-area)
+                            (geometry-height sized))
+                         2))
+            :width (geometry-width sized)
+            :height (geometry-height sized)))
+         (geometry (constrain-client-geometry backend client-id centered
+                                              :work-area work-area))
+         (work-width (x11-work-area-width work-area))
+         (work-height (x11-work-area-height work-area)))
+    (list :x (/ (- (geometry-x geometry) (x11-work-area-x work-area)) work-width)
+          :y (/ (- (geometry-y geometry) (x11-work-area-y work-area)) work-height)
+          :width (/ (geometry-width geometry) work-width)
+          :height (/ (geometry-height geometry) work-height))))
+
+(defun %fixed-size-normal-hints-p (hints)
+  "True only when both axes explicitly declare one positive allowed size."
+  (when hints
+    (let ((min-width (xlib:wm-size-hints-min-width hints))
+          (min-height (xlib:wm-size-hints-min-height hints))
+          (max-width (xlib:wm-size-hints-max-width hints))
+          (max-height (xlib:wm-size-hints-max-height hints)))
+      (and (every (lambda (value) (and (integerp value) (plusp value)))
+                  (list min-width min-height max-width max-height))
+           (= min-width max-width)
+           (= min-height max-height)))))
+
+(declaim (ftype function apply-configured-window-rules))
+
+(defun new-client-placement-decision (backend client-id window)
+  "Choose an initial target for a newly managed client.
+
+A managed WM_TRANSIENT_FOR parent makes the child a float on that parent's
+active Head, even if the user most recently selected another Head. EWMH
+dialog/utility/splash types receive the same centered floating default on the
+focused Head. Ordinary fixed-size clients also default to centered floats,
+subject to configured rules; other clients retain the normal tiled default.
+This policy runs only at adoption, not on later normal-hints changes."
+  (let* ((world (x11-backend-world backend))
+         (info (backend-client-icccm-info backend client-id))
+         (parent-client-id
+           (and info (icccm-client-info-transient-for-client-id info)))
+         (parent-presentation
+           (and parent-client-id
+                (%active-presentation-for-client backend parent-client-id))))
+    (if parent-presentation
+        ;; Modal/transient placement is an ICCCM guarantee, not a user style
+        ;; preference: its parent owns the target Head and it must stay float.
+        (let* ((head-id (presentation-head-id parent-presentation))
+               (head (%head-for-id backend head-id))
+               (parent-window
+                 (gethash parent-client-id
+                          (x11-backend-client-windows backend))))
+          (make-x11-placement-decision
+           :head-id head-id
+           :presentation-id (presentation-id parent-presentation)
+           :activity-id (presentation-activity-id parent-presentation)
+           :kind :float
+           :data (%floating-data-for-window backend client-id window head
+                                             parent-window)
+           :transient-for-client-id parent-client-id
+           :focus-p t))
+        ;; Dialog-like EWMH windows do not always set WM_TRANSIENT_FOR.  They
+        ;; still deserve the conservative non-tiling placement familiar from
+        ;; traditional WMs, but have no invented parent Activity or Head.
+        (let* ((head-id (x11-backend-focused-head-id backend))
+               (presentation (current-presentation world head-id)))
+          (unless presentation
+            (error 'invalid-transition
+                   :description
+                   "The selected Head is blank; start or mount an Activity before opening a window there."))
+          (if (ewmh-client-dialog-like-p backend client-id)
+              (let ((head (%head-for-id backend head-id)))
+                (make-x11-placement-decision
+                 :head-id head-id
+                 :presentation-id (presentation-id presentation)
+                 :activity-id (presentation-activity-id presentation)
+                 :kind :float
+                 :data (%centered-floating-data-for-window backend client-id window head)
+                 :focus-p t))
+              ;; Fixed-size ordinary clients (often startup/updater windows)
+              ;; cannot fill a tile. Float them without a class-wide rule that
+              ;; would also catch the application's resizable main window.
+              ;; Unlike dialogs, they retain the configured focus policy.
+              (let ((fixed-p (%fixed-size-normal-hints-p
+                              (and info (icccm-client-info-normal-hints info)))))
+                (apply-configured-window-rules
+                 backend client-id window
+                 (make-x11-placement-decision
+                  :head-id head-id
+                  :presentation-id (presentation-id presentation)
+                  :activity-id (presentation-activity-id presentation)
+                  :kind (if fixed-p :float :tile)
+                  :data (when fixed-p
+                          (%centered-floating-data-for-window
+                           backend client-id window (%head-for-id backend head-id)))))))))))

src/x11/pointer.lisp

@@ -0,0 +1,285 @@
+(in-package #:lime.x11)
+
+;;;; Pointer routing
+;;;
+;;; A pointer event is only evidence about where the user acted. This layer
+;;; resolves it to a Head/client and delegates focus state to the command
+;;; surface, keeping input delivery separate from leases, ICCCM, and layouts.
+
+(declaim (ftype function x11-backend-hand-cursor))
+
+(defun %set-ui-pointer (backend window clickable-p previous-hand-p)
+  "Update only this UI window, reusing the shared cursor and skipping no-ops."
+  (let ((hand-p (not (null clickable-p))))
+    (unless (eq hand-p previous-hand-p)
+      (setf (xlib:window-cursor window)
+            (if hand-p (x11-backend-hand-cursor backend) :none))
+      ;; Bar motion does not repaint; don't wait for the next event to flush.
+      (xlib:display-force-output (x11-backend-display backend)))
+    hand-p))
+
+(defun %ui-window-pointer-position (backend window)
+  "Return local (X . Y) only if WINDOW is actually under the pointer.
+
+This is a redraw-time snapshot, not a polling timer. Checking the root child
+also excludes UI hidden by another window, not just points outside its bounds."
+  (multiple-value-bind (x y same-screen-p child)
+      (xlib:query-pointer (x11-backend-root backend))
+    (when (and same-screen-p child (= (xlib:window-id child) (xlib:window-id window)))
+      (cons (- x (xlib:drawable-x window)) (- y (xlib:drawable-y window))))))
+
+(defstruct pointer-drag
+  "A transient X11 pointer gesture expressed against one floating placement."
+  client-id
+  head-id
+  presentation-id
+  mode
+  initial-root-x
+  initial-root-y
+  initial-data)
+
+(defun %head-at-root-position (backend root-x root-y)
+  "Return the configured Head containing ROOT-X, ROOT-Y, or NIL for a gap."
+  (find-if
+   (lambda (head-id)
+     (let ((head (%head-for-id backend head-id)))
+       (and (<= (x11-head-x head) root-x)
+            (< root-x (+ (x11-head-x head) (x11-head-width head)))
+            (<= (x11-head-y head) root-y)
+            (< root-y (+ (x11-head-y head) (x11-head-height head))))))
+   (x11-backend-head-ids backend)))
+
+(defun %visible-client-head-id (backend client-id)
+  "Return the active Head currently leasing CLIENT-ID, if any."
+  (let* ((world (x11-backend-world backend))
+         (lease (lease-for-client world client-id)))
+    (when lease
+      (let ((presentation (find-presentation
+                           world (lease-presentation-id lease))))
+        (when (presentation-active-p world presentation)
+          (presentation-head-id presentation))))))
+
+(defun pointer-adopt-client (backend window)
+  "Install Lime's click focus and Super-drag passive grabs on WINDOW.
+
+The passive grab is necessary because ordinary applications place their actual
+content in child windows and select their own ButtonPress events there. With
+OWNER-P false, X reports such a press to the grab owner using WINDOW as its
+event window, so the backend can reliably find the managed client. It is
+intentionally a grab rather than a WINDOW event-mask selection: the latter can
+conflict with a client's own ButtonPress selection."
+  ;; Freeze an ordinary unmodified Button1 so the handler can focus first,
+  ;; then replay the same press to the application. A separate, more specific
+  ;; Super grab owns move/resize; :ANY cannot coexist with that X11 grab.
+  (xlib:grab-button window 1 '(:button-press) :modifiers 0
+                    :sync-pointer-p t)
+  ;; Geometry drags are intentionally opt-in via Super. Once the press starts,
+  ;; MotionNotify and ButtonRelease continue through the active pointer grab.
+  (xlib:grab-button window 1 '(:button-press :button-release :pointer-motion)
+                    :modifiers '(:mod-4) :sync-pointer-p t)
+  ;; Keep the user's dwm convention: Super+middle-click changes only this
+  ;; client's tile/float placement. It is synchronous so we can focus it and
+  ;; release the click without forwarding a WM gesture to the client.
+  (xlib:grab-button window 2 '(:button-press) :modifiers '(:mod-4)
+                    :sync-pointer-p t)
+  (xlib:grab-button window 3 '(:button-press :button-release :pointer-motion)
+                    :modifiers '(:mod-4) :sync-pointer-p t)
+  backend)
+
+(defun pointer-forget-client (backend client-id)
+  "Cancel a drag when CLIENT-ID is retired while its button is down."
+  (let ((drag (x11-backend-pointer-drag backend)))
+    (when (and drag (equal (pointer-drag-client-id drag) client-id))
+      (setf (x11-backend-pointer-drag backend) nil)))
+  backend)
+
+(defun %super-held-p (state)
+  (not (zerop (logand state (xlib:make-state-mask :mod-4)))))
+
+(defun %begin-floating-drag (backend client-id head-id mode root-x root-y time)
+  "Focus CLIENT-ID, then begin a synchronous Super move or resize if it floats."
+  (unwind-protect
+       (progn
+         (backend-focus-client backend client-id :head-id head-id)
+         (let* ((presentation (current-presentation (x11-backend-world backend)
+                                                     head-id))
+                (placement (and presentation
+                                (find client-id (presentation-placements presentation)
+                                      :key #'placement-client-id :test #'equal))))
+           (when (and placement (eq (placement-kind placement) :float)
+                      (not (equal client-id
+                                  (ewmh-fullscreen-client-id-for-head backend head-id))))
+             (setf (x11-backend-pointer-drag backend)
+                   (make-pointer-drag
+                    :client-id client-id :head-id head-id :mode mode
+                    :presentation-id (presentation-id presentation)
+                    :initial-root-x root-x :initial-root-y root-y
+                    :initial-data (copy-list (placement-data placement)))))))
+    ;; Super presses are a WM gesture, never replayed to the client. Releasing
+    ;; the synchronous grab here lets the active grab deliver its motion/release.
+    (xlib:allow-events (x11-backend-display backend) :async-pointer time)))
+
+(defun %clamp (value minimum maximum)
+  (max minimum (min maximum value)))
+
+(defun %drag-geometry (drag work-area root-x root-y)
+  "Return DRAG's new normalized geometry at ROOT-X, ROOT-Y in WORK-AREA."
+  (let* ((data (pointer-drag-initial-data drag))
+         (initial-x (getf data :x))
+         (initial-y (getf data :y))
+         (initial-width (getf data :width))
+         (initial-height (getf data :height))
+         (delta-x (/ (- root-x (pointer-drag-initial-root-x drag))
+                     (max 1 (x11-work-area-width work-area))))
+         (delta-y (/ (- root-y (pointer-drag-initial-root-y drag))
+                     (max 1 (x11-work-area-height work-area)))))
+    (ecase (pointer-drag-mode drag)
+      (:move
+       (list :x (%clamp (+ initial-x delta-x) 0 (- 1 initial-width))
+             :y (%clamp (+ initial-y delta-y) 0 (- 1 initial-height))
+             :width initial-width :height initial-height))
+      (:resize
+       (let* ((maximum-width (- 1 initial-x))
+              (maximum-height (- 1 initial-y))
+              ;; A far-right or far-bottom float can legitimately be smaller
+              ;; than the usual 5% minimum, so cap that minimum by its bounds.
+              (minimum-width (min 1/20 maximum-width))
+              (minimum-height (min 1/20 maximum-height)))
+         (list :x initial-x :y initial-y
+               :width (%clamp (+ initial-width delta-x)
+                              minimum-width maximum-width)
+               :height (%clamp (+ initial-height delta-y)
+                               minimum-height maximum-height)))))))
+
+(defun %coalesce-drag-motion (backend window root-x root-y state)
+  "Consume only consecutive, already queued motion for the same pointer gesture.
+
+Never search past a release, command, lifecycle event, or another window's
+motion. The bounded batch avoids starving the developer mailbox under a flood.
+CLX's nested event reader starts after the event currently being dispatched."
+  (let ((display (x11-backend-display backend)))
+    (loop repeat (min 256 (or (xlib:event-listen display) 0))
+          while
+          (eq :motion
+              (xlib:event-case (display :timeout 0 :peek-p t :discard-p nil
+                                        :force-output-p nil)
+                (:motion-notify ((window next-window) (root-x next-x)
+                                 (root-y next-y) (state next-state))
+                  (if (and (= (xlib:window-id window) (xlib:window-id next-window))
+                           (= state next-state))
+                      (progn
+                        (setf root-x next-x root-y next-y)
+                        (xlib:discard-current-event display)
+                        :motion)
+                      :boundary))
+                (otherwise () :boundary)))))
+  (values root-x root-y))
+
+(defun %drag-current-placement (backend drag)
+  "A gesture cannot follow its client into another draft, Head, or fullscreen."
+  (let* ((presentation (current-presentation
+                        (x11-backend-world backend) (pointer-drag-head-id drag)))
+         (client-id (pointer-drag-client-id drag)))
+    (when (and presentation
+               (equal (presentation-id presentation) (pointer-drag-presentation-id drag))
+               (equal (%visible-client-head-id backend client-id) (pointer-drag-head-id drag))
+               (gethash client-id (x11-backend-client-windows backend))
+               (not (equal client-id
+                           (ewmh-fullscreen-client-id-for-head backend (pointer-drag-head-id drag)))))
+      (let ((placement (find client-id (presentation-placements presentation)
+                             :key #'placement-client-id :test #'equal)))
+        (when (and placement (eq :float (placement-kind placement))) placement)))))
+
+(defun %handle-motion-notify (backend root-x root-y state)
+  "Apply the current floating gesture's latest Head-relative rectangle."
+  (declare (ignore state))
+  (let ((drag (x11-backend-pointer-drag backend)))
+    (when drag
+      (handler-case
+          (let ((placement (%drag-current-placement backend drag)))
+            (if (null placement)
+                (setf (x11-backend-pointer-drag backend) nil)
+                (let* ((work-area (x11-head-work-area backend (pointer-drag-head-id drag)))
+                       (data (%drag-geometry drag work-area root-x root-y)))
+                  ;; Repeated/clamped coordinates do not dirty a checkpoint or
+                  ;; send redundant ConfigureWindow requests.
+                  (unless (every (lambda (key)
+                                   (= (getf data key) (getf (placement-data placement) key)))
+                                 '(:x :y :width :height))
+                    (backend-set-client-floating-geometry
+                     backend (pointer-drag-client-id drag)
+                     :head-id (pointer-drag-head-id drag)
+                     :x (getf data :x) :y (getf data :y)
+                     :width (getf data :width) :height (getf data :height))))))
+        (error (condition)
+          ;; An asynchronously destroyed client or an invalidated gesture must
+          ;; not take down the event loop. Keep the failure inspectable.
+          (setf (x11-backend-last-command-error backend) condition
+                (x11-backend-pointer-drag backend) nil)))))
+  nil)
+
+(defun %handle-button-release (backend button &optional root-x root-y)
+  "Apply the release's final position, then end the matching pointer gesture."
+  (let ((drag (x11-backend-pointer-drag backend)))
+    (when (and drag
+               (or (and (eq (pointer-drag-mode drag) :move) (= button 1))
+                   (and (eq (pointer-drag-mode drag) :resize) (= button 3))))
+      (unwind-protect
+           (when (and root-x root-y)
+             (%handle-motion-notify backend root-x root-y 0))
+        (setf (x11-backend-pointer-drag backend) nil))))
+  nil)
+
+(defun %handle-button-press (backend window root-x root-y button state time)
+  "Apply Lime's initial, deliberately boring click-to-focus policy.
+
+An unmodified Button1 focuses and replays to the app. Super+Button1 moves a
+floating client; Super+Button2 toggles this client's floating placement; and
+Super+Button3 resizes it. Other buttons remain application input until a
+future binding claims them."
+  (let ((client-id (%backend-client-id backend window)))
+    (cond
+      ((and client-id (%super-held-p state) (= button 2))
+       (let ((head-id (%visible-client-head-id backend client-id)))
+         (unwind-protect
+              (when head-id
+                (backend-focus-client backend client-id :head-id head-id)
+                (backend-toggle-client-floating backend client-id :head-id head-id))
+           (xlib:allow-events (x11-backend-display backend)
+                              :async-pointer time))))
+      ((and client-id (%super-held-p state) (member button '(1 3)))
+       (let ((head-id (%visible-client-head-id backend client-id)))
+         (if head-id
+             (%begin-floating-drag backend client-id head-id
+                                   (if (= button 1) :move :resize)
+                                   root-x root-y time)
+             ;; The passive grab can race a lease change. It is still a
+             ;; synchronous grab and must be released even though no gesture
+             ;; can safely start.
+             (xlib:allow-events (x11-backend-display backend)
+                                :async-pointer time))))
+      ((= button 1)
+       (cond
+         (client-id
+          (let ((head-id (%visible-client-head-id backend client-id)))
+            ;; A mapped client should be leased, but stale events are harmless.
+            ;; Always release the synchronous grab, even if the client changed
+            ;; state between the event and this lookup or focus signals.
+            (unwind-protect
+                 (when head-id
+                   (backend-focus-client backend client-id :head-id head-id))
+              ;; This client Button1 arrived through our synchronous passive
+              ;; grab. Reprocess it after focus, bypassing this same grab, so
+              ;; a browser link or widget still receives the first click.
+              (xlib:allow-events (x11-backend-display backend)
+                                 :replay-pointer
+                                 time))))
+         ;; CLX normally interns root window objects, but XIDs are the actual
+         ;; X11 identity and keep this correct if an event arrived through a
+         ;; different window object.
+         ((= (xlib:window-id window)
+             (xlib:window-id (x11-backend-root backend)))
+          (let ((head-id (%head-at-root-position backend root-x root-y)))
+            (when head-id
+              (backend-focus-head-background backend head-id)))))))
+    t))

src/x11/randr.lisp

@@ -0,0 +1,348 @@
+(in-package #:lime.x11)
+
+;;;; RandR physical-output discovery
+;;;
+;;; RandR describes hardware outputs and the CRTCs currently driving them.
+;;; Lime renders logical Heads, so an active CRTC is the correct unit: cloned
+;;; displays share one CRTC and must not become overlapping Heads.  This file
+;;; only observes that topology.  Deciding how to migrate a task when an
+;;; output appears or vanishes remains an explicit higher-level policy.
+
+(defstruct x11-randr-output
+  output-id
+  name
+  crtc-id
+  connection
+  x
+  y
+  width
+  height)
+
+(defun %x11-randr-active-output-p (output)
+  (and (eq (x11-randr-output-connection output) :connected)
+       (plusp (or (x11-randr-output-crtc-id output) 0))
+       (plusp (or (x11-randr-output-width output) 0))
+       (plusp (or (x11-randr-output-height output) 0))))
+
+(defun %x11-randr-output-label (output)
+  (let ((name (x11-randr-output-name output)))
+    (if (and (stringp name) (plusp (length name)))
+        name
+        (format nil "output-~D" (x11-randr-output-output-id output)))))
+
+(defun %x11-randr-output-name< (first second)
+  (string< (%x11-randr-output-label first)
+           (%x11-randr-output-label second)))
+
+(defun %x11-head-position< (first second)
+  (or (< (x11-head-x first) (x11-head-x second))
+      (and (= (x11-head-x first) (x11-head-x second))
+           (or (< (x11-head-y first) (x11-head-y second))
+               (and (= (x11-head-y first) (x11-head-y second))
+                    (string< (x11-head-head-id first)
+                             (x11-head-head-id second)))))))
+
+(defun %x11-randr-heads-from-outputs (outputs primary-output-id)
+  "Make one stable X11-HEAD per active RandR CRTC.
+
+An output name is a friendlier and more stable user-facing Head id than a
+numeric X resource id. When outputs are cloned, PRIMARY-OUTPUT-ID wins as the
+representative when present; otherwise the lexically first output name wins.
+The retained OUTPUT-IDS records all physical outputs feeding that Head."
+  (let ((groups (make-hash-table :test #'eql)))
+    (dolist (output outputs)
+      (when (%x11-randr-active-output-p output)
+        (push output (gethash (x11-randr-output-crtc-id output) groups))))
+    (let (heads)
+      (maphash
+       (lambda (crtc-id group)
+         (declare (ignore crtc-id))
+         (let* ((ordered (sort (copy-list group) #'%x11-randr-output-name<))
+                (representative
+                  (or (find primary-output-id ordered
+                            :key #'x11-randr-output-output-id :test #'eql)
+                      (first ordered))))
+           (push (make-x11-head
+                  :head-id (%x11-randr-output-label representative)
+                  :x (x11-randr-output-x representative)
+                  :y (x11-randr-output-y representative)
+                  :width (x11-randr-output-width representative)
+                  :height (x11-randr-output-height representative)
+                  :output-id (x11-randr-output-output-id representative)
+                  :output-ids (mapcar #'x11-randr-output-output-id ordered)
+                  :output-name (%x11-randr-output-label representative))
+                 heads)))
+       groups)
+      (sort heads #'%x11-head-position<))))
+
+(defun %x11-randr-version-at-least-p (major minor required-major required-minor)
+  (or (> major required-major)
+      (and (= major required-major) (>= minor required-minor))))
+
+(defun %x11-randr-available-p (display)
+  (not (null (xlib:query-extension display "RANDR"))))
+
+(defun x11-randr-discover-topology (display root)
+  "Return a snapshot of active RandR Heads, or NIL when RandR is unavailable.
+
+No shell command, root geometry heuristic, or monitor-management request is
+used. The snapshot reads active outputs and their CRTCs directly from the X
+server, which lets a normal two-monitor desktop and a nested test server use
+the same adapter path."
+  (when (%x11-randr-available-p display)
+    (multiple-value-bind (major minor) (xlib:rr-query-version display)
+      (when (%x11-randr-version-at-least-p major minor 1 2)
+        (multiple-value-bind (timestamp config-timestamp crtcs output-ids modes names)
+            (xlib:rr-get-screen-resources root)
+          (declare (ignore crtcs modes names))
+          (let* ((primary-output-id
+                   (when (%x11-randr-version-at-least-p major minor 1 3)
+                     (xlib:rr-get-output-primary root)))
+                 (outputs
+                   (loop for output-id in output-ids
+                         for output = (%x11-randr-read-output
+                                       display output-id config-timestamp)
+                         when output collect output)))
+            (make-x11-randr-topology
+             :major-version major
+             :minor-version minor
+             :timestamp timestamp
+             :config-timestamp config-timestamp
+             :primary-output-id primary-output-id
+             :outputs outputs
+             :heads (%x11-randr-heads-from-outputs outputs primary-output-id))))))))
+
+(defun %x11-randr-read-output (display output-id config-timestamp)
+  "Read one active output and its CRTC rectangle, or return NIL when inactive."
+  (multiple-value-bind (status output-timestamp crtc-id width-mm height-mm connection
+                        subpixel crtcs preferred-modes modes clones name)
+      (xlib:rr-get-output-info display output-id config-timestamp)
+    (declare (ignore output-timestamp width-mm height-mm subpixel crtcs
+                     preferred-modes modes clones))
+    (when (and (eq status :success)
+               (eq connection :connected)
+               (plusp crtc-id))
+      (multiple-value-bind (crtc-status crtc-timestamp x y width height mode
+                            current-rotation possible-rotations outputs possible-outputs)
+          (xlib:rr-get-crtc-info display crtc-id config-timestamp)
+        (declare (ignore crtc-timestamp mode current-rotation possible-rotations
+                         outputs possible-outputs))
+        (when (and (eq crtc-status :success) (plusp width) (plusp height))
+          (make-x11-randr-output :output-id output-id
+                                 :name name
+                                 :crtc-id crtc-id
+                                 :connection connection
+                                 :x x :y y :width width :height height))))))
+
+(defun x11-randr-enable-notifications (backend)
+  "Subscribe a RandR-discovered backend to topology-change notifications."
+  (xlib:rr-select-input
+   (x11-backend-root backend)
+   '(:screen-change-notify-mask
+     :crtc-change-notify-mask
+     :output-change-notify-mask))
+  (xlib:display-force-output (x11-backend-display backend))
+  backend)
+
+(defun %x11-head-signatures (heads)
+  (mapcar (lambda (head)
+            (list (x11-head-head-id head)
+                  (x11-head-x head)
+                  (x11-head-y head)
+                  (x11-head-width head)
+                  (x11-head-height head)
+                  (x11-head-output-id head)
+                  (copy-list (x11-head-output-ids head))))
+          heads))
+
+(defun %same-head-id-set-p (first second)
+  "Whether two Head-id sequences name the same logical Heads, regardless of order."
+  (and (= (length first) (length second))
+       (every (lambda (head-id) (member head-id second :test #'equal)) first)))
+
+(defun backend-randr-status (backend)
+  "Return the observed physical topology without implying a migration policy."
+  (let ((topology (x11-backend-randr-topology backend)))
+    (list :head-source (x11-backend-head-source backend)
+          :topology-dirty-p (x11-backend-randr-topology-dirty-p backend)
+          :active-head-ids (backend-head-ids backend)
+          :discovered-head-ids
+          (and topology
+               (mapcar #'x11-head-head-id (x11-randr-topology-heads topology)))
+          :outputs
+          (and topology
+               (mapcar (lambda (output)
+                         (list :id (x11-randr-output-output-id output)
+                               :name (%x11-randr-output-label output)
+                               :crtc-id (x11-randr-output-crtc-id output)
+                               :x (x11-randr-output-x output)
+                               :y (x11-randr-output-y output)
+                               :width (x11-randr-output-width output)
+                               :height (x11-randr-output-height output)))
+                       (x11-randr-topology-outputs topology))))))
+
+(defun backend-randr-topology-report (backend)
+  "Return the explicit migration choices for the latest observed RandR topology.
+
+The embedded :REPORT is a pure HEAD-TOPOLOGY-REPORT: it names retained,
+added, and removed logical Heads, plus the live Presentations on removed
+Heads.  It makes no routing decision and changes neither the model nor X11.
+Use BACKEND-BUILD-RANDR-TOPOLOGY-PLAN with explicit moves, then
+BACKEND-APPLY-RANDR-TOPOLOGY-PLAN to perform the chosen reconciliation."
+  (unless (eq (x11-backend-head-source backend) :randr)
+    (error 'invalid-transition
+           :description "This backend was not started from RandR-discovered Heads."))
+  (let ((topology (x11-backend-randr-topology backend)))
+    (if (and topology (x11-randr-topology-heads topology))
+        (let ((report
+                (preflight-head-topology-reconciliation
+                 (x11-backend-world backend)
+                 (mapcar #'x11-head-head-id
+                         (x11-randr-topology-heads topology)))))
+          (list :report report
+                :topology-dirty-p (x11-backend-randr-topology-dirty-p backend)
+                :discovered-head-ids
+                (head-topology-report-desired-head-ids report)
+                :added-head-ids (head-topology-report-added-head-ids report)
+                :retained-head-ids (head-topology-report-retained-head-ids report)
+                :removed-head-ids (head-topology-report-removed-head-ids report)
+                :removed-active-sources
+                (head-topology-report-removed-active-sources report)))
+        (list :report nil
+              :topology-dirty-p t
+              :reason (if topology :no-active-heads :randr-unavailable)))))
+
+(defun backend-build-randr-topology-plan (backend &key moves)
+  "Build, but do not apply, a RandR topology plan with explicit MOVES.
+
+MOVES is a list of HEAD-TOPOLOGY-MOVE values. Each move routes a live
+Presentation from a disappearing Head to one discovered destination Head.
+Any omitted removed source is intentionally suspended; added Heads remain
+blank until another ordinary Activity/View command mounts something there."
+  (let ((report (getf (backend-randr-topology-report backend) :report)))
+    (or report
+        (error 'invalid-transition
+               :description "RandR has no usable topology snapshot to reconcile."))
+    (build-head-topology-reconciliation-plan report :moves moves)))
+
+(declaim (ftype function apply-active-presentation
+                         reconcile-head-bars))
+
+(defun %install-randr-head-rectangles (backend heads)
+  "Replace adapter rectangles only after their Head ids have been proven stable."
+  ;; Reuse the existing invariant checks before mutating the live backend.
+  (%configure-heads (x11-backend-root backend) (x11-backend-head-id backend) heads)
+  (clrhash (x11-backend-heads backend))
+  (dolist (head heads)
+    (setf (gethash (x11-head-head-id head) (x11-backend-heads backend)) head))
+  (setf (x11-backend-head-ids backend) (mapcar #'x11-head-head-id heads)
+        (x11-backend-head-id backend) (x11-head-head-id (first heads)))
+  backend)
+
+(defun %sync-focus-after-randr-topology-reconciliation (backend)
+  "Keep adapter-local input routing on an existing Head after a migration."
+  (unless (gethash (x11-backend-focused-head-id backend)
+                   (x11-backend-heads backend))
+    (setf (x11-backend-focused-head-id backend)
+          (first (x11-backend-head-ids backend))))
+  (let ((presentation
+          (current-presentation (x11-backend-world backend)
+                                (x11-backend-focused-head-id backend))))
+    (setf (x11-backend-activity-id backend)
+          (and presentation (presentation-activity-id presentation))
+          (x11-backend-focus-root-override-p backend) nil))
+  backend)
+
+(defun backend-apply-randr-topology-plan (backend plan)
+  "Apply an explicit RandR PLAN to the model and current X11 rectangles.
+
+The adapter rereads RandR immediately before commit. If another output change
+altered the desired Head-id set while a frontend was presenting choices, it
+refuses the stale plan without moving any Activity, Presentation, or Lease."
+  (unless (eq (x11-backend-head-source backend) :randr)
+    (error 'invalid-transition
+           :description "This backend was not started from RandR-discovered Heads."))
+  (unless (typep plan 'head-topology-plan)
+    (error 'invalid-transition
+           :description "RandR reconciliation needs a HEAD-TOPOLOGY-PLAN."))
+  (let ((topology (x11-randr-discover-topology
+                   (x11-backend-display backend) (x11-backend-root backend))))
+    (unless topology
+      (setf (x11-backend-randr-topology-dirty-p backend) t)
+      (error 'invalid-transition
+             :description "RandR became unavailable before topology reconciliation."))
+    (let ((heads (x11-randr-topology-heads topology)))
+      (unless (%same-head-id-set-p
+               (head-topology-plan-desired-head-ids plan)
+               (mapcar #'x11-head-head-id heads))
+        (setf (x11-backend-randr-topology backend) topology
+              (x11-backend-randr-topology-dirty-p backend) t)
+        (error 'stale-transition-plan))
+      (let ((result (commit-head-topology-reconciliation-plan
+                     (x11-backend-world backend) plan)))
+        (%install-randr-head-rectangles backend heads)
+        (reconcile-head-bars backend)
+        (setf (x11-backend-randr-topology backend) topology
+              (x11-backend-randr-topology-dirty-p backend) nil)
+        (%sync-focus-after-randr-topology-reconciliation backend)
+        (apply-active-presentation backend)
+        result))))
+
+(defun backend-reconcile-randr-heads (backend &key moves)
+  "Convenience orchestration for an already-chosen explicit RandR migration.
+
+Interactive frontends normally keep query, choice, and mutation visibly
+separate through BACKEND-RANDR-TOPOLOGY-REPORT,
+BACKEND-BUILD-RANDR-TOPOLOGY-PLAN, and BACKEND-APPLY-RANDR-TOPOLOGY-PLAN.
+This wrapper is useful for a REPL or IPC caller that has already chosen MOVES."
+  (backend-apply-randr-topology-plan
+   backend (backend-build-randr-topology-plan backend :moves moves)))
+
+(defun backend-refresh-randr-heads (backend)
+  "Safely apply a same-topology RandR geometry refresh.
+
+Resolution or position changes with the same Head ids are safe: all existing
+Presentations and Leases retain their owners, so Lime replaces only adapter
+rectangles and rerenders. Added or removed Heads return a pending report
+instead. Use the explicit RandR topology-report/plan/apply commands to make
+that migration decision."
+  (unless (eq (x11-backend-head-source backend) :randr)
+    (error 'invalid-transition
+           :description "This backend was not started from RandR-discovered Heads."))
+  (let ((topology (x11-randr-discover-topology
+                   (x11-backend-display backend) (x11-backend-root backend))))
+    (unless topology
+      (setf (x11-backend-randr-topology-dirty-p backend) t)
+      (return-from backend-refresh-randr-heads
+        (append (backend-randr-status backend)
+                (list :refreshed-p nil :reason :randr-unavailable))))
+    (setf (x11-backend-randr-topology backend) topology)
+    (let ((heads (x11-randr-topology-heads topology)))
+      (if (%same-head-id-set-p (mapcar #'x11-head-head-id heads)
+                               (x11-backend-head-ids backend))
+          (progn
+            (%install-randr-head-rectangles backend heads)
+            (reconcile-head-bars backend)
+            (setf (x11-backend-randr-topology-dirty-p backend) nil)
+            (apply-active-presentation backend)
+            (append (backend-randr-status backend)
+                    (list :refreshed-p t :reason :same-topology)))
+          (progn
+            (setf (x11-backend-randr-topology-dirty-p backend) t)
+            (append (backend-randr-status backend)
+                    (list :refreshed-p nil :reason :topology-changed)))))))
+
+(defun x11-randr-handle-change (backend)
+  "Record a RandR event as pending; do not silently migrate task state."
+  (when (eq (x11-backend-head-source backend) :randr)
+    (let ((topology (x11-randr-discover-topology
+                     (x11-backend-display backend) (x11-backend-root backend))))
+      (setf (x11-backend-randr-topology backend) topology
+            (x11-backend-randr-topology-dirty-p backend)
+            (or (null topology)
+                (not (equal (%x11-head-signatures
+                             (x11-randr-topology-heads topology))
+                            (%x11-head-signatures
+                             (loop for head-id in (x11-backend-head-ids backend)
+                                   collect (%head-for-id backend head-id))))))))
+  (backend-randr-status backend)))

src/x11/render.lisp

@@ -0,0 +1,286 @@
+(in-package #:lime.x11)
+
+;;;; Declarative render planning and imperative X11 execution
+;;;
+;;; The model never calls CLX.  This file is the narrow reconciliation seam:
+;;; BUILD-RENDER-PLAN observes a stable Lime world and describes the required
+;;; effects; EXECUTE-RENDER-PLAN is the only code here that performs them.
+;;; That keeps additions such as stacking, borders, size hints, and
+;;; animations from leaking into core transitions or client lifecycle code.
+
+(defstruct x11-effect
+  "One X11 operation requested by an X11-RENDER-PLAN.
+
+KIND is currently :CONFIGURE, :MAP, :UNMAP, :RAISE, :FOCUS, or :FOCUS-ROOT.  Effects
+refer to Lime client ids so plans remain inspectable without exposing CLX
+window objects."
+  kind
+  client-id
+  geometry
+  (border-width 0)
+  border-color)
+
+(defstruct x11-render-plan
+  "A complete desired reconciliation of Lime's active Presentations to X11."
+  world-revision
+  (effects '()))
+
+(defun %geometry-for-client (geometries client-id)
+  (cdr (assoc client-id geometries :test #'equal)))
+
+(defun %active-client-geometries (backend)
+  "Return content rectangles and, as a second value, their border widths."
+  (let ((world (x11-backend-world backend))
+        (geometries '())
+        (borders '()))
+    (dolist (head-id (x11-backend-head-ids backend))
+      (let ((presentation (current-presentation world head-id)))
+        (when presentation
+          (let* ((head (%head-for-id backend head-id))
+                 (work-area (x11-head-work-area backend head))
+                 (fullscreen-client-id
+                   (ewmh-fullscreen-client-id-for-head backend head-id))
+                 (layout (resolve-presentation-layout
+                          presentation
+                          (x11-work-area-width work-area)
+                          (x11-work-area-height work-area)
+                          :x (x11-work-area-x work-area)
+                          :y (x11-work-area-y work-area)))
+                 (leased-client-ids (presentation-leased-client-ids world presentation))
+                 ;; Count what this Head will actually tile, not Activity
+                 ;; membership or saved slots whose leases live elsewhere.
+                 ;; Monocle naturally contributes just its one resolved tile.
+                 (visible-tile-count
+                   (loop for placement in (presentation-placements presentation)
+                         for client-id = (placement-client-id placement)
+                         count (and (eq :tile (placement-kind placement))
+                                    (member client-id leased-client-ids :test #'equal)
+                                    (%geometry-for-client layout client-id)))))
+            (dolist (client-id leased-client-ids)
+              (let ((geometry
+                      (if (equal client-id fullscreen-client-id)
+                          ;; A genuine fullscreen request intentionally skips
+                          ;; normal-hint adjustment: it owns the complete
+                          ;; configured Head, exactly as a game asks.
+                          (make-geometry :x (x11-head-x head)
+                                         :y (x11-head-y head)
+                                         :width (x11-head-width head)
+                                         :height (x11-head-height head))
+                          (%geometry-for-client layout client-id))))
+                (when geometry
+                  (multiple-value-bind (content border)
+                      (if (equal client-id fullscreen-client-id)
+                          (values geometry 0)
+                          (%styled-client-geometry
+                           backend client-id geometry work-area
+                           (eq :tile
+                               (placement-kind
+                                (find client-id (presentation-placements presentation)
+                                      :key #'placement-client-id :test #'equal)))
+                           :visible-tile-count visible-tile-count))
+                    (push (cons client-id content) geometries)
+                    (push (cons client-id border) borders)))))))))
+    (values geometries borders)))
+
+(defun %registered-client-ids (backend)
+  "Return registered Lime client ids in a stable order for inspectable plans."
+  (let (client-ids)
+    (maphash (lambda (client-id window)
+               (declare (ignore window))
+               (push client-id client-ids))
+             (x11-backend-client-windows backend))
+    (sort client-ids #'string< :key #'princ-to-string)))
+
+(defun %focused-client-id (backend geometries)
+  "Return the selected Head's visible focus client, if it has an X window."
+  (let* ((world (x11-backend-world backend))
+         (presentation (current-presentation
+                        world (x11-backend-focused-head-id backend)))
+         (client-id (or (ewmh-fullscreen-client-id-for-head
+                         backend (x11-backend-focused-head-id backend))
+                        (and presentation
+                             (presentation-focus-client-id presentation)))))
+    (when (and client-id
+               (%geometry-for-client geometries client-id)
+               (gethash client-id (x11-backend-client-windows backend)))
+      client-id)))
+
+(defun %active-floating-client-ids (backend geometries)
+  "Return visible floating client ids in stable Head/placement order."
+  (let ((world (x11-backend-world backend))
+        (client-ids '()))
+    (dolist (head-id (x11-backend-head-ids backend))
+      (let ((presentation (current-presentation world head-id)))
+        (when presentation
+          (dolist (placement (presentation-placements presentation))
+            (let ((client-id (placement-client-id placement)))
+              (when (and (eq (placement-kind placement) :float)
+                         (member client-id
+                                 (presentation-leased-client-ids world presentation)
+                                 :test #'equal)
+                         (%geometry-for-client geometries client-id))
+                (push client-id client-ids)))))))
+    (nreverse client-ids)))
+
+(defun build-render-plan (backend)
+  "Describe the X11 effects needed to realize every configured active Head.
+
+The selected Head contributes the sole input-focus target.  A blank selected
+Head explicitly focuses the root window, keeping the focus operation defined
+without inventing a global workspace or Head policy."
+  (multiple-value-bind (geometries borders) (%active-client-geometries backend)
+    (let* ((world (x11-backend-world backend))
+           (effects '())
+           (style (%window-appearance backend))
+           (focus-client-id
+             (unless (x11-backend-focus-root-override-p backend)
+               (%focused-client-id backend geometries)))
+           (floating-client-ids (%active-floating-client-ids backend geometries))
+           (fullscreen-client-ids (ewmh-active-fullscreen-client-ids backend)))
+      (dolist (client-id (%registered-client-ids backend))
+        (let ((geometry (%geometry-for-client geometries client-id)))
+          (if geometry
+              (progn
+                (push (make-x11-effect
+                       :kind :configure :client-id client-id :geometry geometry
+                       :border-width (cdr (assoc client-id borders :test #'equal))
+                       :border-color
+                       (if (equal client-id focus-client-id)
+                           (window-appearance-focused-border style)
+                           (window-appearance-unfocused-border style)))
+                      effects)
+                (push (make-x11-effect :kind :map :client-id client-id) effects))
+              (push (make-x11-effect :kind :unmap :client-id client-id) effects))))
+      ;; Floats deliberately sit above tiled content.  Raising the focused
+      ;; float last gives ordinary click focus the expected stacking behavior
+      ;; without turning z-order into hidden model state yet.
+      (dolist (client-id
+               (append
+                (remove-if (lambda (client-id)
+                             (member client-id fullscreen-client-ids :test #'equal))
+                           floating-client-ids)
+                fullscreen-client-ids))
+        (push (make-x11-effect :kind :raise :client-id client-id) effects))
+      (push (if focus-client-id
+                (make-x11-effect :kind :focus :client-id focus-client-id)
+                (make-x11-effect :kind :focus-root))
+            effects)
+      (make-x11-render-plan :world-revision (world-revision world)
+                            :effects (nreverse effects)))))
+
+(defun %configure-window (window geometry border-width border-pixel)
+  (xlib:with-state (window)
+    (setf (xlib:drawable-x window) (geometry-x geometry)
+          (xlib:drawable-y window) (geometry-y geometry)
+          (xlib:drawable-width window) (max 1 (geometry-width geometry))
+          (xlib:drawable-height window) (max 1 (geometry-height geometry))
+          (xlib:drawable-border-width window) border-width)
+    (when border-pixel
+      (setf (xlib:window-border window) border-pixel))))
+
+(defun %execute-x11-effect (backend effect)
+  (let* ((client-id (x11-effect-client-id effect))
+         (window (and client-id
+                      (gethash client-id (x11-backend-client-windows backend)))))
+    (ecase (x11-effect-kind effect)
+      (:configure
+       (when window
+         (%remember-client-border backend client-id window)
+         (%configure-window window (x11-effect-geometry effect)
+                            (x11-effect-border-width effect)
+                            (and (x11-effect-border-color effect)
+                                 (%border-pixel backend (x11-effect-border-color effect))))))
+      (:map
+       (when window
+         ;; WM_STATE is part of the visible-client transition itself, not a
+         ;; speculative model field.  The ICCCM cache makes repeated render
+         ;; plans cheap while adoption and reappearance still publish NORMAL.
+         (unless (eq (let ((info (backend-client-icccm-info backend client-id)))
+                       (and info (icccm-client-info-wm-state info)))
+                     :normal)
+           (icccm-set-client-state backend client-id window :normal)
+           (xlib:map-window window))))
+      (:unmap
+       (when window
+         ;; Remember this before the request: root-level UnmapNotify is also
+         ;; how an application tells us it withdrew.  The lifecycle layer
+         ;; consumes exactly one token instead of mistaking View hiding for a
+         ;; destroyed task client.
+         (unless (eq (let ((info (backend-client-icccm-info backend client-id)))
+                       (and info (icccm-client-info-wm-state info)))
+                     :iconic)
+           (%note-pending-unmap backend window)
+           (icccm-set-client-state backend client-id window :iconic)
+           (xlib:unmap-window window))))
+      (:raise
+       (when window
+         (setf (xlib:window-priority window) :above)))
+      (:focus
+       (when window
+         (icccm-focus-client backend client-id window)
+         (ewmh-set-active-window backend client-id)
+         (%attention-acknowledge-client backend client-id)))
+      (:focus-root
+       (xlib:set-input-focus (x11-backend-display backend)
+                             (x11-backend-root backend)
+                             :pointer-root)
+       (ewmh-set-active-window backend nil)))))
+
+(defun execute-render-plan (backend plan)
+  "Execute a current X11-RENDER-PLAN and flush it as one CLX batch."
+  (unless (= (x11-render-plan-world-revision plan)
+             (world-revision (x11-backend-world backend)))
+    (error 'invalid-transition
+           :description "Refusing to execute a stale X11 render plan."))
+  (dolist (effect (x11-render-plan-effects plan))
+    (%execute-x11-effect backend effect))
+  ;; Rendering can raise floats/fullscreen clients, so publish the resulting
+  ;; root-child stacking order only after all visual effects have been issued.
+  (ewmh-sync-client-lists backend)
+  (xlib:display-force-output (x11-backend-display backend))
+  backend)
+
+(defun %floating-client-configure-effect (backend presentation client-id)
+  "Resolve one leased float using the same layout, borders, and hints as a full pass.
+
+No mapping, restacking, focus, or root-property effects are implied. A hidden
+or unavailable client is left alone; fullscreen keeps its physical-Head size
+while the underlying float rectangle can still be edited for later restoration."
+  (let* ((head-id (presentation-head-id presentation))
+         (world (x11-backend-world backend)))
+    (when (and (presentation-client-floating-p presentation client-id)
+               (member client-id (presentation-leased-client-ids world presentation)
+                       :test #'equal)
+               (not (equal client-id (ewmh-fullscreen-client-id-for-head backend head-id))))
+      (let* ((area (x11-head-work-area backend head-id))
+             (geometry (%geometry-for-client
+                        (resolve-presentation-layout
+                         presentation (x11-work-area-width area) (x11-work-area-height area)
+                         :x (x11-work-area-x area) :y (x11-work-area-y area))
+                        client-id)))
+        (when geometry
+          (multiple-value-bind (content border)
+              (%styled-client-geometry backend client-id geometry area nil)
+            (make-x11-effect :kind :configure :client-id client-id
+                             :geometry content :border-width border)))))))
+
+(defun apply-floating-client-geometry (backend presentation client-id)
+  "Flush a geometry-only update without synchronous X queries or a full repaint."
+  (let ((effect (%floating-client-configure-effect backend presentation client-id)))
+    (when effect (%execute-x11-effect backend effect)))
+  (when (x11-backend-display backend)
+    (xlib:display-force-output (x11-backend-display backend)))
+  backend)
+
+(declaim (ftype function %navigation-state))
+
+(defun apply-active-presentation (backend)
+  "Build and execute the current X11 reconciliation plan.
+
+This compatibility entry point remains convenient for small callers; new
+frontends may inspect BUILD-RENDER-PLAN before explicitly executing it.  The
+Head bar is adapter UI, so it is redrawn afterward rather than becoming a
+model effect."
+  (%navigation-state backend)
+  (execute-render-plan backend (build-render-plan backend))
+  (render-head-bars backend))

src/x11/resilience.lisp

@@ -0,0 +1,154 @@
+(in-package #:lime.x11)
+
+;;;; X11 race policy, bounded diagnostics, and explicit recovery primitives.
+;;;; No automatic retry of arbitrary model mutations and no persistence here.
+
+(define-condition x11-client-disappeared (error)
+  ((window-id :initarg :window-id :reader disappeared-window-id))
+  (:report (lambda (condition stream)
+             (format stream "X11 client #x~X disappeared during a query."
+                     (disappeared-window-id condition)))))
+
+(defun %diagnostic-condition-message (condition)
+  ;; A broken user condition printer must not turn recovery into a new fault.
+  (handler-case
+      (let ((*print-length* 12) (*print-level* 4) (*print-circle* t))
+        (let ((message (princ-to-string condition)))
+          (subseq message 0 (min 4096 (length message)))))
+    (error () "[Condition could not be printed]")))
+
+(defun backend-record-diagnostic (backend condition &key (source :event-loop) backtrace)
+  "Retain at most 32 reports, newest first; never print whole model/window objects."
+  (let ((report (list :time (get-universal-time) :source source
+                      :event (copy-list (x11-backend-event-context backend))
+                      :condition-type (type-of condition)
+                      :message (%diagnostic-condition-message condition)
+                      :backtrace backtrace)))
+    (push report (x11-backend-diagnostics backend))
+    (when (> (length (x11-backend-diagnostics backend)) 32)
+      (setf (cdr (nthcdr 31 (x11-backend-diagnostics backend))) nil))
+    report))
+
+(defun backend-diagnostics (backend)
+  "Return copied reports plus the count of harmless X11 timing races."
+  (list :expected-x-errors (x11-backend-expected-x-error-count backend)
+        :reports (copy-tree (x11-backend-diagnostics backend))))
+
+(defun %external-resource-p (backend display resource-id)
+  "Exclude the root and Lime-owned UI/resources from destroyed-client policy."
+  (and (integerp resource-id) (plusp resource-id)
+       (/= resource-id (xlib:window-id (x11-backend-root backend)))
+       (/= (logand resource-id (lognot (xlib:display-resource-id-mask display)))
+           (xlib:display-resource-id-base display))))
+
+(defun %expected-x-error-policy (error-key major asynchronous external-p)
+  "Return :IGNORE, :CLIENT-GONE, or NIL for a specific protocol failure.
+
+Never suppress BadAccess (root ownership/grabs), BadValue, or faults in our UI.
+Synchronous queries must abort: ignoring their error would wait for no reply."
+  (cond
+    ((and asynchronous (eq error-key 'xlib:match-error) (= major 42)) :ignore)
+    ((and external-p
+          (or (and (eq error-key 'xlib:window-error)
+                   (member major '(2 3 8 10 12 15 18 19 20 25 28 29 38 42)))
+              (and (eq error-key 'xlib:drawable-error) (= major 14))))
+     (if asynchronous :ignore :client-gone))))
+
+(defun %handle-display-error (backend display error-key &rest arguments
+                              &key asynchronous resource-id (major 0) &allow-other-keys)
+  (let ((policy (%expected-x-error-policy
+                 error-key major asynchronous
+                 (%external-resource-p backend display resource-id))))
+    (case policy
+      (:ignore (incf (x11-backend-expected-x-error-count backend)) nil)
+      (:client-gone
+       (incf (x11-backend-expected-x-error-count backend))
+       (error 'x11-client-disappeared :window-id resource-id))
+      (otherwise (apply #'xlib:default-error-handler display error-key arguments)))))
+
+(defun %forget-disappeared-client (backend window-id)
+  (let* ((client-id (gethash window-id (x11-backend-window-clients backend)))
+         (window (and client-id (gethash client-id (x11-backend-client-windows backend)))))
+    (when window
+      (%forget-window backend window)
+      (%forget-pending-unmaps backend window)
+      (%retire-managed-client backend client-id :window-id window-id))
+    (let ((external (gethash window-id (x11-backend-ewmh-external-windows backend))))
+      (when external (ewmh-forget-external-window backend external)))))
+
+(defun %call-with-client-race-handling (backend function)
+  "Abandon a failed client query at an event/adoption boundary, not the session."
+  (handler-case (funcall function)
+    (x11-client-disappeared (condition)
+      (%forget-disappeared-client backend (disappeared-window-id condition))
+      (apply-active-presentation backend)
+      nil)))
+
+(defun %call-with-cleanup-diagnostics (backend function)
+  (handler-case (funcall function)
+    (error (condition)
+      (backend-record-diagnostic backend condition :source :cleanup)
+      nil)))
+
+(defun backend-release-input (backend)
+  "Release Lime's active grabs independently, even if its overlay is broken."
+  (setf (x11-backend-pointer-drag backend) nil)
+  (let ((display (x11-backend-display backend)))
+    (when display
+      (dolist (function (list (lambda () (xlib:allow-events display :async-both))
+                             (lambda () (xlib:ungrab-pointer display))
+                             (lambda () (xlib:ungrab-keyboard display))
+                             (lambda () (backend-close-command-palette backend :acknowledge-p nil))
+                             (lambda () (xlib:display-force-output display))))
+        (%call-with-cleanup-diagnostics backend function))))
+  backend)
+
+(defun %validate-client-registrations (backend)
+  "Do not resume a valid core world whose adapter mappings are half-mutated."
+  (let ((world (x11-backend-world backend))
+        (windows (x11-backend-client-windows backend))
+        (clients (x11-backend-window-clients backend)))
+    (dolist (activity (list-activities world))
+      (dolist (id (activity-client-ids activity))
+        (unless (gethash id windows)
+          (error "Client ~S has no X11 window registration; repair or restart before resuming." id))))
+    (maphash (lambda (id window)
+               (find-client world id)
+               (unless (equal id (gethash (xlib:window-id window) clients))
+                 (error "Inconsistent X11 registration for client ~S." id)))
+             windows)
+    (maphash (lambda (window-id id)
+               (let ((window (gethash id windows)))
+                 (unless (and window (= window-id (xlib:window-id window)))
+                   (error "Inconsistent X11 registration for window ~S." window-id))))
+             clients))
+  t)
+
+(defun backend-reconcile-after-error (backend)
+  "Validate the retained world, retire vanished clients, and render before resuming.
+
+This is an explicit recovery attempt, not a rollback or a fresh empty world.
+An invalid model, disconnected server, or still-broken renderer keeps recovery
+from succeeding. Queued lifecycle/input events are not blindly discarded."
+  (unless (x11-backend-display backend)
+    (error "The X connection is closed; restart Lime instead of resuming it."))
+  (validate-world (x11-backend-world backend))
+  (let* ((children (xlib:query-tree (x11-backend-root backend)))
+         (live-ids (mapcar #'xlib:window-id children))
+         (gone '()))
+    (maphash (lambda (window-id client-id)
+               (declare (ignore client-id))
+               (unless (member window-id live-ids) (push window-id gone)))
+             (x11-backend-window-clients backend))
+    (dolist (window-id gone) (%forget-disappeared-client backend window-id))
+    ;; Complete an interrupted adoption only when that was the failed event.
+    (let* ((event (x11-backend-event-context backend))
+           (window (and (eq :map-request (getf event :kind))
+                        (find (getf event :window-id) children :key #'xlib:window-id))))
+      (when window
+        (%call-with-client-race-handling backend (lambda () (manage-window backend window))))))
+  (validate-world (x11-backend-world backend))
+  (%validate-client-registrations backend)
+  (apply-active-presentation backend)
+  (xlib:display-finish-output (x11-backend-display backend))
+  backend)

src/x11/session-settings.lisp

@@ -0,0 +1,239 @@
+(in-package #:lime.x11)
+
+;;;; Display-local settings for applications, not cursor rendering or model state.
+;;;; No GTK config files, dconf, process-global environment, or D-Bus activation
+;;;; environment are changed. All X operations run on the backend owner thread.
+
+(defstruct cursor-session-settings
+  theme size window selection (serial 0)
+  resources-before resources-last resources-owned-p
+  (manager-status :following-system))
+
+(defvar *cursor-session-settings* (make-hash-table :test #'eq))
+
+(defun %cursor-settings-window-equal (one two)
+  (or (eq one two) (and one two (xlib:window-equal one two))))
+
+(defun %xsettings-cursor-bytes (theme size serial)
+  "Encode the two optional cursor settings, using explicit little-endian bytes."
+  (let ((bytes (make-array 0 :element-type '(unsigned-byte 8)
+                            :adjustable t :fill-pointer 0)))
+    (labels ((number (value count)
+               (dotimes (i count) (vector-push-extend (ldb (byte 8 (* i 8)) value) bytes)))
+             (text (value length-size)
+               (let ((utf8 (babel:string-to-octets value :encoding :utf-8)))
+                 (number (length utf8) length-size)
+                 (map nil (lambda (byte) (vector-push-extend byte bytes)) utf8)))
+             (pad () (loop until (zerop (mod (length bytes) 4)) do (number 0 1)))
+             (header (type name)
+               (number type 1) (number 0 1) (text name 2) (pad) (number serial 4)))
+      (number 0 4) ; LSBFirst plus three padding bytes.
+      (number serial 4)
+      (number (+ (if theme 1 0) (if size 1 0)) 4)
+      (when theme (header 1 "Gtk/CursorThemeName") (text theme 4) (pad))
+      (when size (header 0 "Gtk/CursorThemeSize") (number size 4)))
+    bytes))
+
+(defun %cursor-resource-records (text)
+  "Keep physical text intact, grouping backslash-continued resource records."
+  (let ((start 0) (records nil))
+    (loop for end below (length text)
+          when (and (char= (char text end) #\Newline)
+                    (evenp (loop for i downfrom (1- end) to start
+                                 while (char= (char text i) #\\) count t)))
+            do (push (subseq text start (1+ end)) records) (setf start (1+ end)))
+    (when (< start (length text)) (push (subseq text start) records))
+    (nreverse records)))
+
+(defun %cursor-resource-key (record)
+  (let* ((colon (position #\: record))
+         (key (and colon (string-trim '(#\Space #\Tab) (subseq record 0 colon)))))
+    (find key '("Xcursor.theme" "Xcursor.size") :test #'equal)))
+
+(defun %cursor-resource-entries (text key)
+  (remove-if-not (lambda (record) (equal key (%cursor-resource-key record)))
+                 (%cursor-resource-records (or text ""))))
+
+(defun %replace-cursor-resource (text key records)
+  (let ((remaining (format nil "~{~A~}"
+                           (remove-if (lambda (record) (equal key (%cursor-resource-key record)))
+                                      (%cursor-resource-records (or text ""))))))
+    (if (null records) remaining
+        (format nil "~A~A~{~A~}" remaining
+                (if (or (zerop (length remaining)) (char= (char remaining (1- (length remaining))) #\Newline))
+                    "" (string #\Newline)) records))))
+
+(defun %unpublished-cursor-resources (state current)
+  "Undo only our own entries; concurrent changes to any other resource survive."
+  (if (not (and state (cursor-session-settings-resources-owned-p state))) current
+      (let ((before (cursor-session-settings-resources-before state))
+            (last (cursor-session-settings-resources-last state)))
+        (if (equal current last) before
+            (let ((result current))
+              (dolist (key '("Xcursor.theme" "Xcursor.size") result)
+                (let ((ours (%cursor-resource-entries last key)))
+                  (when (and ours (equal ours (%cursor-resource-entries current key)))
+                    (setf result (%replace-cursor-resource
+                                  result key (%cursor-resource-entries before key)))))))))))
+
+(defun %read-session-resources (root)
+  (multiple-value-bind (bytes type format) (xlib:get-property root :RESOURCE_MANAGER)
+    (when type
+      (unless (and (eq type :STRING) (= format 8))
+        (error "RESOURCE_MANAGER is not a STRING/8 property; refusing to overwrite it."))
+      (map 'string #'code-char bytes))))
+
+(defun %write-session-resources (root text)
+  (if text
+      (xlib:change-property root :RESOURCE_MANAGER (map 'vector #'char-code text) :STRING 8)
+      (xlib:delete-property root :RESOURCE_MANAGER)))
+
+(defun %cursor-system-resources (backend)
+  "Resolve defaults without feeding our last publication back into NIL config."
+  (let ((database (xlib:make-resource-database))
+        (text (%unpublished-cursor-resources
+               (gethash backend *cursor-session-settings*)
+               (%read-session-resources (x11-backend-root backend)))))
+    (when text
+      (with-input-from-string (in text) (xlib:read-resources database in)))
+    database))
+
+(defun %cursor-resource-value (theme)
+  ;; STRING/8 properties contain bytes, while XSETTINGS explicitly uses UTF-8.
+  (with-output-to-string (out)
+    (loop for byte across (babel:string-to-octets theme :encoding :utf-8)
+          do (when (= byte 92) (write-char #\\ out)) (write-char (code-char byte) out))))
+
+(defun %publish-cursor-resources (backend state theme size)
+  (let ((display (x11-backend-display backend)) (root (x11-backend-root backend)))
+    (xlib:with-server-grabbed (display)
+      (let* ((current (%read-session-resources root))
+             (before (%unpublished-cursor-resources state current))
+             (next before))
+        (when theme
+          (setf next (%replace-cursor-resource next "Xcursor.theme"
+                       (list (format nil "Xcursor.theme: ~A~%" (%cursor-resource-value theme))))))
+        (when size
+          (setf next (%replace-cursor-resource next "Xcursor.size"
+                       (list (format nil "Xcursor.size: ~D~%" size)))))
+        ;; Record ownership before the request, so a later X error is reversible.
+        (setf (cursor-session-settings-resources-before state) before
+              (cursor-session-settings-resources-last state) next
+              (cursor-session-settings-resources-owned-p state) (or theme size))
+        (unless (equal current next) (%write-session-resources root next))))
+    (xlib:display-force-output display)))
+
+(defun %destroy-cursor-settings-window (state)
+  (when (cursor-session-settings-window state)
+    ;; Destroying our window releases only our ownership, never a successor's.
+    (xlib:destroy-window (cursor-session-settings-window state))
+    (setf (cursor-session-settings-window state) nil)))
+
+(defun %cursor-settings-timestamp (display window)
+  (xlib:change-property window :_LIME_SETTINGS_TIME #(0) :INTEGER 8)
+  ;; Preserve unrelated queued input/MapRequests. Only our timestamp is consumed.
+  (or (xlib:event-case (display :timeout 2 :discard-p nil :force-output-p t)
+        (:property-notify ((:window event-window) atom time)
+          (when (and (%cursor-settings-window-equal window event-window) (eq atom :_LIME_SETTINGS_TIME)) time)))
+      (error "Timed out obtaining an XSETTINGS ownership timestamp.")))
+
+(defun %publish-cursor-xsettings (backend state theme size)
+  (let* ((display (x11-backend-display backend))
+         (root (x11-backend-root backend))
+         (selection (or (cursor-session-settings-selection state)
+                        (setf (cursor-session-settings-selection state)
+                              (intern (format nil "_XSETTINGS_S~D"
+                                              (position (x11-backend-x-screen backend)
+                                                        (xlib:display-roots display))) :keyword)))))
+    (cond
+      ((not (or theme size))
+       (%destroy-cursor-settings-window state)
+       (setf (cursor-session-settings-manager-status state) :following-system))
+      (t
+       (let ((owner (xlib:selection-owner display selection)))
+         (unless (%cursor-settings-window-equal owner (cursor-session-settings-window state))
+           (%destroy-cursor-settings-window state))
+         (if (and owner (not (%cursor-settings-window-equal owner (cursor-session-settings-window state))))
+             (setf (cursor-session-settings-manager-status state) :external-manager)
+             (progn
+               (unless (cursor-session-settings-window state)
+                 (let* ((window (xlib:create-window :parent root :x -1 :y -1 :width 1 :height 1
+                                                    :override-redirect :on :event-mask '(:property-change)))
+                        (claimed nil))
+                   (unwind-protect
+                        (let ((time (%cursor-settings-timestamp display window)))
+                          (xlib:with-server-grabbed (display)
+                            (unless (xlib:selection-owner display selection)
+                              (setf (xlib:selection-owner display selection time) window)
+                              (when (%cursor-settings-window-equal window (xlib:selection-owner display selection))
+                                (setf claimed t (cursor-session-settings-window state) window)
+                                ;; A client responding to MANAGER must never see
+                                ;; an owner without its initial settings property.
+                                (xlib:change-property
+                                 window :_XSETTINGS_SETTINGS
+                                 (%xsettings-cursor-bytes theme size
+                                  (ldb (byte 32 0) (1+ (cursor-session-settings-serial state))))
+                                 :_XSETTINGS_SETTINGS 8)
+                                (xlib:send-event root :client-message '(:structure-notify)
+                                                 :window root :type :MANAGER :format 32
+                                                 :data (vector time (xlib:intern-atom display selection)
+                                                               (xlib:window-id window) 0 0))))))
+                     (unless claimed (xlib:destroy-window window)))))
+               (if (cursor-session-settings-window state)
+                   (progn
+                     (setf (cursor-session-settings-serial state)
+                           (ldb (byte 32 0) (1+ (cursor-session-settings-serial state))))
+                     (xlib:change-property
+                      (cursor-session-settings-window state) :_XSETTINGS_SETTINGS
+                      (%xsettings-cursor-bytes theme size (cursor-session-settings-serial state))
+                      :_XSETTINGS_SETTINGS 8)
+                     (setf (cursor-session-settings-manager-status state) :published))
+                   (setf (cursor-session-settings-manager-status state) :external-manager)))))))
+    (xlib:display-force-output display)))
+
+(defun %apply-cursor-session-settings (backend style)
+  (%validate-ui-cursor-style style)
+  (when (x11-backend-display backend)
+    (let* ((theme (ui-cursor-style-theme style))
+           (size (unless (eq theme :core) (ui-cursor-style-size style)))
+           (theme (and (stringp theme) theme))
+           (state (or (gethash backend *cursor-session-settings*)
+                      (setf (gethash backend *cursor-session-settings*) (make-cursor-session-settings)))))
+      (%publish-cursor-resources backend state theme size)
+      (%publish-cursor-xsettings backend state theme size)
+      (xlib:display-finish-output (x11-backend-display backend))
+      (setf (cursor-session-settings-theme state) theme
+            (cursor-session-settings-size state) size))))
+
+(defun %handle-cursor-settings-selection-clear (backend window selection)
+  (let ((state (gethash backend *cursor-session-settings*)))
+    (when (and state (eq selection (cursor-session-settings-selection state))
+               (%cursor-settings-window-equal window (cursor-session-settings-window state)))
+      (%destroy-cursor-settings-window state)
+      (setf (cursor-session-settings-manager-status state) :external-manager)
+      t)))
+
+(defun %shutdown-cursor-session-settings (backend)
+  (let ((state (gethash backend *cursor-session-settings*)))
+    (when state
+      (unwind-protect (%publish-cursor-resources backend state nil nil)
+        (%destroy-cursor-settings-window state)
+        (remhash backend *cursor-session-settings*)))))
+
+(defun %cursor-session-report (backend)
+  (let ((state (gethash backend *cursor-session-settings*)))
+    (if state (list :xsettings (cursor-session-settings-manager-status state)
+                    :theme (cursor-session-settings-theme state) :size (cursor-session-settings-size state)
+                    :xresources (not (null (cursor-session-settings-resources-owned-p state))))
+        (list :xsettings :following-system))))
+
+(defun %cursor-session-launch-argv (backend argv)
+  "Overlay only the child's environment; never change the Lisp process or D-Bus."
+  (let* ((state (gethash backend *cursor-session-settings*))
+         (theme (and state (cursor-session-settings-theme state)))
+         (size (and state (cursor-session-settings-size state))))
+    (if (or theme size)
+        (append (list "env")
+                (when theme (list (format nil "XCURSOR_THEME=~A" theme)))
+                (when size (list (format nil "XCURSOR_SIZE=~D" size))) argv)
+        argv)))

src/x11/status-desktop.lisp

@@ -0,0 +1,265 @@
+(in-package #:lime.x11)
+
+;;;; Optional desktop sources. All blocking I/O belongs to managed workers.
+;;;; MPD uses its native protocol; playerctl/pactl are event bridges, not polls.
+
+(defmacro %with-status-query-timeout (&body body)
+  #+sbcl `(sb-ext:with-timeout 3 ,@body)
+  #-sbcl (declare (ignore body))
+  #-sbcl `(error "Desktop status I/O currently requires SBCL."))
+
+(defun %status-read-line (stream &optional (limit 16384))
+  "Bound external line sizes, including peers that never send a newline."
+  (with-output-to-string (out)
+    (loop for count from 0
+          for char = (read-char stream nil nil)
+          do (unless char (error "Status source disconnected."))
+             (when (char= char #\Newline) (return))
+             (when (>= count limit) (error "Status source line exceeds ~D characters." limit))
+             (unless (char= char #\Return) (write-char char out)))))
+
+(defun %call-with-status-process (worker argv function)
+  (let ((process (uiop:launch-program (append '("env" "LC_ALL=C.UTF-8") argv)
+                                      :input nil :output :stream :error-output nil
+                                      :external-format :utf-8)))
+    (unwind-protect
+         (%call-with-status-resource
+          worker (lambda () (uiop:terminate-process process :urgent t))
+          (lambda () (funcall function (uiop:process-info-output process) process)))
+      ;; Reap only our own helper; no shells, killall, or global daemon changes.
+      (ignore-errors (uiop:terminate-process process :urgent t))
+      (ignore-errors (uiop:wait-process process))
+      (ignore-errors (close (uiop:process-info-output process))))))
+
+(defun %status-query (worker argv)
+  (%call-with-status-process
+   worker argv
+   (lambda (stream process)
+     ;; Bound one-shot helpers without a watchdog polling thread. Subscription
+     ;; reads deliberately have no timeout. Lime's developer target is SBCL.
+     (%with-status-query-timeout
+       (let ((line (%status-read-line stream)))
+         (unless (zerop (uiop:wait-process process)) (error "Status query failed: ~A" (first argv)))
+         line)))))
+
+(defun %wall-time ()
+  #+sbcl (multiple-value-bind (seconds microseconds) (sb-ext:get-time-of-day)
+           (+ 2208988800 seconds (/ microseconds 1000000d0)))
+  #-sbcl (get-universal-time))
+
+(defun %next-minute-delay (time)
+  (- 60 (mod time 60)))
+
+(defun %clock-snapshot (time)
+  (multiple-value-bind (second minute hour day month year weekday daylight-p timezone)
+      (decode-universal-time (floor time))
+    (declare (ignore second))
+    (list :universal-time (floor time) :minute minute :hour hour :day day
+          :month month :year year :weekday weekday :daylight-p daylight-p :timezone timezone)))
+
+(defun make-clock-status-provider (&key (id :clock) (formatter #'format-clock-status)
+                                       foreground click-action maximum-width)
+  "Local date/time, freshly aligned to the next wall-clock minute after each wake."
+  (make-status-provider
+   :id id :formatter formatter :foreground foreground :maximum-width maximum-width :click-action click-action
+   :run (lambda (worker)
+          (loop until (status-cancelled-p worker)
+                do (status-publish worker (%clock-snapshot (%wall-time)))
+                   (unless (status-wait worker (%next-minute-delay (%wall-time))) (return))))))
+
+(defun %volume-percent (line)
+  ;; pactl's first channel, matching the user's old bar; never confuse raw
+  ;; PulseAudio units or dB with the percentage. Keep legitimate >100% values.
+  (let ((end (position #\% line)))
+    (unless end (error "No percentage in audio volume response."))
+    (let ((start end))
+      (loop while (and (plusp start) (digit-char-p (char line (1- start)))) do (decf start))
+      (or (parse-integer line :start start :end end :junk-allowed t)
+          (error "Malformed audio volume percentage.")))))
+
+(defun %volume-event-p (line)
+  ;; Client connect/disconnect events from our own queries MUST NOT refresh.
+  (or (search " on sink #" line) (search " on server #" line) (search " on card #" line)))
+
+(defun %volume-snapshot (worker)
+  (let* ((sink (%status-query worker '("pactl" "get-default-sink")))
+         (mute (%status-query worker (list "pactl" "get-sink-mute" sink)))
+         (volume (%status-query worker (list "pactl" "get-sink-volume" sink))))
+    (unless (member mute '("Mute: yes" "Mute: no") :test #'string=)
+      (error "Unrecognized audio mute response."))
+    (list :volume (%volume-percent volume) :muted-p (string= mute "Mute: yes") :sink sink)))
+
+(defun %run-volume-status (worker &key (subscribe #'%call-with-status-process) (snapshot #'%volume-snapshot))
+  (funcall subscribe
+           worker '("pactl" "subscribe")
+           (lambda (stream process)
+             (declare (ignore process))
+             ;; Subscribe before taking the initial snapshot. Events received
+             ;; during queries remain buffered and trigger another snapshot.
+             (status-publish worker (funcall snapshot worker))
+             (loop until (status-cancelled-p worker)
+                   for line = (%status-read-line stream)
+                   do (let ((dirty (%volume-event-p line)))
+                        ;; Collapse bursts already queued during a query. No
+                        ;; debounce timer delaying the first visible update.
+                        (loop while (listen stream)
+                              do (when (%volume-event-p (%status-read-line stream)) (setf dirty t)))
+                        (when dirty (status-publish worker (funcall snapshot worker))))))))
+
+(defun make-volume-status-provider (&key (id :volume) (formatter #'format-volume-status)
+                                         foreground maximum-width
+                                         (click-action
+                                           (lambda (backend head-id)
+                                             (declare (ignore head-id))
+                                             (backend-launch-program backend '("pactl" "set-sink-mute" "@DEFAULT_SINK@" "toggle")))))
+  "Subscribe to PulseAudio/PipeWire-Pulse events; clicking toggles sink mute."
+  (make-status-provider
+   :id id :formatter formatter :foreground foreground :maximum-width maximum-width :click-action click-action
+   :run #'%run-volume-status))
+
+(defstruct (music-status-provider (:include status-provider)
+                                 (:constructor %make-music-status-provider))
+  source sources host port password)
+
+(defun %music-snapshot (state title source)
+  (list :state (cond ((member state '("play" "Playing") :test #'string=) :playing)
+                     ((member state '("pause" "Paused") :test #'string=) :paused)
+                     ((member state '("stop" "Stopped") :test #'string=) :stopped)
+                     (t :unknown))
+        :title title :source source))
+
+(defun %mpd-quote (value)
+  (with-output-to-string (out)
+    (write-char #\" out)
+    (loop for char across value do
+      (when (member char '(#\Newline #\Return)) (error "Newline in MPD argument."))
+      (when (member char '(#\\ #\")) (write-char #\\ out))
+      (write-char char out))
+    (write-char #\" out)))
+
+(defun %mpd-send (stream command)
+  (let ((bytes (babel:string-to-octets (concatenate 'string command (string #\Newline)) :encoding :utf-8)))
+    (write-sequence bytes stream) (force-output stream)))
+
+(defun %mpd-line (stream)
+  (let ((bytes (make-array 128 :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
+    (loop for byte = (read-byte stream)
+          until (= byte 10)
+          do (when (>= (length bytes) 65536) (error "Oversized MPD response."))
+             (vector-push-extend byte bytes))
+    (babel:octets-to-string bytes :encoding :utf-8)))
+
+(defun %mpd-response (stream)
+  (loop for count below 1024 for line = (%mpd-line stream)
+        when (string= line "OK") return pairs
+        when (uiop:string-prefix-p "ACK " line) do (error "MPD rejected status request.")
+        collect (let ((separator (search ": " line)))
+                  (if separator (cons (subseq line 0 separator) (subseq line (+ separator 2)))
+                      (cons line ""))) into pairs
+        finally (error "Too many MPD response fields.")))
+
+(defun %run-mpd-status (worker provider)
+  (let* ((socket (usocket:socket-connect (music-status-provider-host provider)
+                                        (music-status-provider-port provider)
+                                        :element-type '(unsigned-byte 8)
+                                        :timeout 3 :read-timeout nil))
+         (stream (usocket:socket-stream socket)))
+    (unwind-protect
+         (%call-with-status-resource
+          worker (lambda () (usocket:socket-shutdown socket :io))
+          (lambda ()
+            (%with-status-query-timeout
+              (unless (uiop:string-prefix-p "OK MPD " (%mpd-line stream))
+                (error "Not an MPD server."))
+              (when (music-status-provider-password provider)
+                (%mpd-send stream (concatenate 'string "password " (%mpd-quote (music-status-provider-password provider))))
+                (%mpd-response stream)))
+            (loop until (status-cancelled-p worker)
+                  do (%with-status-query-timeout
+                       (%mpd-send stream "status")
+                       (let ((status (%mpd-response stream)))
+                         (%mpd-send stream "currentsong")
+                         (let* ((song (%mpd-response stream))
+                                (title (or (cdr (assoc "Title" song :test #'string=))
+                                           (let ((file (cdr (assoc "file" song :test #'string=))))
+                                             (and file (pathname-name file))))))
+                           (status-publish worker (%music-snapshot (cdr (assoc "state" status :test #'string=))
+                                                                    title :mpd)))))
+                     ;; The SAME connection accumulates changes between the
+                     ;; snapshot and IDLE, eliminating a subscribe/query gap.
+                     (%mpd-send stream "idle player playlist")
+                     (%mpd-response stream))))
+      (ignore-errors (usocket:socket-close socket)))))
+
+(defun %mpris-line-snapshot (line source)
+  (let ((separator (position #\Tab line)))
+    (when separator (%music-snapshot (subseq line 0 separator) (subseq line (1+ separator)) source))))
+
+(defun %run-mpris-status (worker provider)
+  (%call-with-status-process
+   worker (list "playerctl" "--player" (music-status-provider-source provider)
+                "--follow" "metadata" "--format" (format nil "{{status}}~C{{title}}" #\Tab))
+   (lambda (stream process)
+     (declare (ignore process))
+     (loop until (status-cancelled-p worker)
+           do (status-publish worker (%mpris-line-snapshot (%status-read-line stream)
+                                                          (music-status-provider-source provider)))))))
+
+(defun make-music-status-provider (&key (id :music) (source :mpd) (sources '(:mpd "spotify"))
+                                       (mpd-host "127.0.0.1") (mpd-port 6600) mpd-password
+                                       (maximum-width 320) (formatter #'format-music-status) foreground
+                                       (click-action nil click-action-supplied-p))
+  "SOURCE is :MPD or a playerctl player name. Source selection and media controls
+share this object, rather than scraping or rewriting another bar's script."
+  (unless (and (listp sources) (member source sources :test #'equal)
+               (every (lambda (value) (or (eq value :mpd) (and (stringp value) (plusp (length value))))) sources)
+               (stringp mpd-host) (integerp mpd-port) (<= 1 mpd-port 65535)
+               (or (null mpd-password) (stringp mpd-password))
+               (integerp maximum-width) (plusp maximum-width))
+    (error "Invalid music status source configuration."))
+  (let ((provider (%make-music-status-provider :id id :source source :sources (copy-list sources)
+                                               :host mpd-host :port mpd-port :password mpd-password
+                                               :maximum-width maximum-width :formatter formatter :foreground foreground)))
+    (setf (status-provider-run provider)
+          (lambda (worker)
+            (if (eq (music-status-provider-source provider) :mpd)
+                (%run-mpd-status worker provider) (%run-mpris-status worker provider)))
+          (status-provider-click-action provider)
+          (if click-action-supplied-p click-action (lambda (backend head-id)
+                             (declare (ignore head-id))
+                             (backend-music-command backend :toggle :id id))))
+    provider))
+
+(defun %backend-music-provider (backend id)
+  (or (find-if (lambda (provider) (and (typep provider 'music-status-provider)
+                                      (equal id (status-provider-id provider))))
+                (x11-backend-head-bar-status-providers backend))
+      (error 'invalid-transition :description "No matching music status provider is configured.")))
+
+(defun backend-cycle-music-source (backend &key (id :music))
+  (let* ((provider (%backend-music-provider backend id))
+         (runtime (x11-backend-status-runtime backend))
+         (worker (find provider (status-runtime-workers runtime) :key #'status-worker-provider)))
+    (%stop-status-worker worker)
+    (setf (music-status-provider-source provider)
+          (or (second (member (music-status-provider-source provider)
+                              (music-status-provider-sources provider) :test #'equal))
+              (first (music-status-provider-sources provider)))
+          (status-runtime-workers runtime)
+          (substitute (%start-status-worker runtime provider) worker (status-runtime-workers runtime)))
+    (render-head-bars backend)
+    (music-status-provider-source provider)))
+
+(defun %music-command-argv (provider command)
+  (let* ((source (music-status-provider-source provider))
+         (verb (ecase command (:toggle "toggle") (:next "next") (:previous "prev"))))
+     (if (eq source :mpd)
+         (list "mpc" "--host" (if (music-status-provider-password provider)
+                                  (format nil "~A@~A" (music-status-provider-password provider) (music-status-provider-host provider))
+                                  (music-status-provider-host provider))
+               "--port" (write-to-string (music-status-provider-port provider)) verb)
+         (list "playerctl" "--player" source
+               (ecase command (:toggle "play-pause") (:next "next") (:previous "previous"))))))
+
+(defun backend-music-command (backend command &key (id :music))
+  (backend-launch-program backend (%music-command-argv (%backend-music-provider backend id) command)))

src/x11/status-format.lisp

@@ -0,0 +1,41 @@
+(in-package #:lime.x11)
+
+;;;; Optional presentation helpers, independent of subscriptions and commands.
+;;;; Configurations may parameterize these or supply entirely different Lisp
+;;;; formatters. Text remains plain text, never executable color/icon markup.
+
+(defun %status-icon-label (icon label gap &optional icon-foreground)
+  (if (or (null icon) (equal icon "")) label
+      (let ((text (format nil "~A~A~A" icon gap label)))
+        (if icon-foreground
+            (%validate-head-bar-segment
+             (make-head-bar-segment :text text :prefix-length (length icon)
+                                    :prefix-foreground icon-foreground))
+            text))))
+
+(defun format-music-status (data &key (playing-icon "") (paused-icon "")
+                                    (icon-gap " ") (untitled "Untitled track") icon-foreground)
+  "Format a music snapshot; stopped/unknown playback is hidden by this helper."
+  (when (member (getf data :state) '(:playing :paused))
+    (let ((title (getf data :title)))
+      (%status-icon-label (if (eq (getf data :state) :playing) playing-icon paused-icon)
+                          (if (and title (plusp (length title))) title untitled) icon-gap icon-foreground))))
+
+(defun format-volume-status (data &key (icon "") (muted-icon "")
+                                     (icon-gap "  ") (muted-label "Muted") icon-foreground)
+  "Format a volume snapshot; mute and channel volume remain independent data."
+  (if (getf data :muted-p)
+      (%status-icon-label muted-icon muted-label icon-gap icon-foreground)
+      (%status-icon-label icon (format nil "~D%" (getf data :volume)) icon-gap icon-foreground)))
+
+(defun format-clock-status (data &key (icon "") (icon-gap "  ") twenty-four-hour-p icon-foreground)
+  "Format local date/time data. Supply a custom formatter for other date styles."
+  (let ((hour (getf data :hour)))
+    (%status-icon-label
+     icon
+     (format nil "~A ~A ~2,'0D, ~2,'0D:~2,'0D"
+             (aref #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") (getf data :weekday))
+             (aref #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+                   (1- (getf data :month)))
+             (getf data :day) (if twenty-four-hour-p hour (1+ (mod (1- hour) 12))) (getf data :minute))
+     icon-gap icon-foreground)))

src/x11/status.lisp

@@ -0,0 +1,234 @@
+(in-package #:lime.x11)
+
+;;;; Managed, event-driven status sources. No worker touches the WM connection,
+;;;; the world, or the renderer. A separate, serialized notification connection
+;;;; sends one coalesced event to wake even a completely idle X event loop.
+
+(defstruct status-provider
+  "RUN publishes data with STATUS-PUBLISH and waits for source events.
+FORMATTER receives a copy of cached data on the X thread and returns a string,
+HEAD-BAR-SEGMENT, or NIL. It performs no I/O. CLICK-ACTION also runs on the X
+thread with (BACKEND HEAD-ID). Plain string-publishing providers still work."
+  id run (formatter #'identity) click-action maximum-width foreground)
+
+(defstruct status-worker
+  provider runtime thread
+  (lock (bt:make-lock "Lime status worker"))
+  (condition (bt:make-condition-variable))
+  cancelled-p value error
+  (cancel-functions '()))
+
+(defstruct status-runtime
+  window display target
+  (lock (bt:make-lock "Lime status notification"))
+  dirty-p closed-p
+  (workers '()))
+
+(defun %validate-status-providers (providers)
+  (unless (and (listp providers)
+               (every (lambda (provider)
+                        (or (functionp provider)
+                            (and (typep provider 'status-provider)
+                                 (status-provider-id provider)
+                                 (functionp (status-provider-run provider))
+                                 (functionp (status-provider-formatter provider))
+                                 (or (null (status-provider-foreground provider))
+                                     (%bar-color-p (status-provider-foreground provider)))
+                                 (or (null (status-provider-maximum-width provider))
+                                     (and (integerp (status-provider-maximum-width provider))
+                                          (plusp (status-provider-maximum-width provider))))
+                                 (or (null (status-provider-click-action provider))
+                                     (functionp (status-provider-click-action provider))))))
+                      providers))
+    (error 'invalid-transition :description "Status providers must be functions or valid STATUS-PROVIDER objects."))
+  (let ((managed (remove-if #'functionp providers)))
+    (unless (= (length managed)
+               (length (remove-duplicates managed :key #'status-provider-id :test #'equal)))
+      (error 'invalid-transition :description "Managed status provider ids must be unique.")))
+  providers)
+
+(defun status-cancelled-p (worker)
+  (bt:with-lock-held ((status-worker-lock worker))
+    (status-worker-cancelled-p worker)))
+
+(defun status-wait (worker seconds)
+  "Interruptible timer, for deadlines/reconnection, not continuous polling."
+  (bt:with-lock-held ((status-worker-lock worker))
+    (unless (status-worker-cancelled-p worker)
+      (bt:condition-wait (status-worker-condition worker) (status-worker-lock worker)
+                         :timeout seconds))
+    (not (status-worker-cancelled-p worker))))
+
+(defun %notify-status (runtime)
+  (bt:with-lock-held ((status-runtime-lock runtime))
+    (unless (or (status-runtime-closed-p runtime) (status-runtime-dirty-p runtime))
+      (setf (status-runtime-dirty-p runtime) t)
+      (xlib:send-event (status-runtime-target runtime) :client-message nil
+                       :window (status-runtime-target runtime)
+                       :type :_lime_status_changed :format 32 :data '(0 0 0 0 0))
+      (xlib:display-force-output (status-runtime-display runtime)))))
+
+(defun %copy-status-value (value)
+  "Snapshot a data tree across the worker/presentation boundary.
+
+No mutable strings/conses are shared with a publisher or a user formatter."
+  (typecase value
+    (string (copy-seq value))
+    (cons (cons (%copy-status-value (car value)) (%copy-status-value (cdr value))))
+    ((or symbol number character) value)
+    (t (error "Status values must be scalar/string/list data, not ~S." (type-of value)))))
+
+(defun status-publish (worker value)
+  "Cache a data snapshot (NIL means unavailable), waking X when data changes.
+Data may be a string, scalar, or list tree. Formatting never runs here."
+  (setf value (%copy-status-value value))
+  (let ((changed nil))
+    (bt:with-lock-held ((status-worker-lock worker))
+      (unless (status-worker-cancelled-p worker)
+        (setf (status-worker-error worker) nil)
+        (unless (equal value (status-worker-value worker))
+          (setf (status-worker-value worker) value changed t))))
+    (when changed (%notify-status (status-worker-runtime worker))))
+  (%copy-status-value value))
+
+(defun %call-with-status-resource (worker cancel function)
+  "Register an owned resource before blocking; cancellation unblocks its I/O."
+  (bt:with-lock-held ((status-worker-lock worker))
+    (when (status-worker-cancelled-p worker)
+      (funcall cancel)
+      (return-from %call-with-status-resource nil))
+    (push cancel (status-worker-cancel-functions worker)))
+  (unwind-protect (funcall function)
+    (bt:with-lock-held ((status-worker-lock worker))
+      (setf (status-worker-cancel-functions worker)
+            (remove cancel (status-worker-cancel-functions worker))))))
+
+(defun %run-status-worker (worker)
+  (let ((delay 1))
+    (loop until (status-cancelled-p worker)
+          do (let ((started (get-internal-real-time)))
+               (handler-case
+                   (funcall (status-provider-run (status-worker-provider worker)) worker)
+                 (error (condition)
+                   ;; Disconnected services never leave stale "playing"/volume data.
+                   (status-publish worker nil)
+                   (bt:with-lock-held ((status-worker-lock worker))
+                     (setf (status-worker-error worker) (princ-to-string condition)))))
+               (when (> (- (get-internal-real-time) started)
+                        (* 30 internal-time-units-per-second))
+                 (setf delay 1)))
+             (unless (status-wait worker delay) (return))
+             (setf delay (min 30 (* 2 delay))))))
+
+(defun %start-status-worker (runtime provider)
+  (let ((worker (make-status-worker :provider provider :runtime runtime)))
+    (setf (status-worker-thread worker)
+          (bt:make-thread (lambda () (%run-status-worker worker))
+                          :name (format nil "Lime status ~A" (status-provider-id provider))))
+    worker))
+
+(defun %stop-status-worker (worker)
+  (bt:with-lock-held ((status-worker-lock worker))
+    (setf (status-worker-cancelled-p worker) t)
+    ;; Cancellation functions must be short, non-blocking shutdown/kill calls.
+    (dolist (cancel (status-worker-cancel-functions worker)) (ignore-errors (funcall cancel)))
+    (bt:condition-notify (status-worker-condition worker)))
+  (when (status-worker-thread worker) (bt:join-thread (status-worker-thread worker))))
+
+(defun %make-status-runtime (backend)
+  (let ((display nil) (window nil))
+    (handler-case
+        (progn
+          (setf display (xlib:open-default-display (x11-backend-display-name backend))
+                window (xlib:create-window :parent (x11-backend-root backend)
+                                           :x -1 :y -1 :width 1 :height 1
+                                           :override-redirect :on))
+          ;; Ensure this resource exists before any publisher sends to its XID.
+          (xlib:display-finish-output (x11-backend-display backend))
+          (xlib:intern-atom display :_lime_status_changed)
+          (make-status-runtime :display display :window window
+                               :target (xlib::make-window :display display :id (xlib:window-id window))))
+      (error (condition)
+        (when window (ignore-errors (xlib:destroy-window window)))
+        (when display (ignore-errors (xlib:close-display display)))
+        (error condition)))))
+
+(defun %reconcile-status-providers (backend providers)
+  (let* ((managed (remove-if #'functionp providers))
+         (runtime (or (x11-backend-status-runtime backend)
+                      (when managed
+                        (setf (x11-backend-status-runtime backend)
+                              (%make-status-runtime backend))))))
+    (when runtime
+      (dolist (worker (copy-list (status-runtime-workers runtime)))
+        (unless (member (status-worker-provider worker) managed :test #'eq)
+          (%stop-status-worker worker)
+          (setf (status-runtime-workers runtime) (remove worker (status-runtime-workers runtime)))))
+      (dolist (provider managed)
+        (unless (find provider (status-runtime-workers runtime) :key #'status-worker-provider :test #'eq)
+          (push (%start-status-worker runtime provider) (status-runtime-workers runtime))))
+      (unless managed (%shutdown-status-runtime backend)))))
+
+(defun %shutdown-status-runtime (backend)
+  (let ((runtime (x11-backend-status-runtime backend)))
+    (when runtime
+      (dolist (worker (status-runtime-workers runtime)) (%stop-status-worker worker))
+      (bt:with-lock-held ((status-runtime-lock runtime))
+        (setf (status-runtime-closed-p runtime) t)
+        (xlib:close-display (status-runtime-display runtime)))
+      (xlib:destroy-window (status-runtime-window runtime))
+      (setf (x11-backend-status-runtime backend) nil))))
+
+(defun %handle-status-notification (backend window type)
+  (let ((runtime (x11-backend-status-runtime backend)))
+    (when (and runtime (eq type :_lime_status_changed)
+               (= (xlib:window-id window) (xlib:window-id (status-runtime-window runtime))))
+      (bt:with-lock-held ((status-runtime-lock runtime))
+        (setf (status-runtime-dirty-p runtime) nil))
+      (render-head-bars backend)
+      t)))
+
+(defun %format-status-segment (provider value)
+  "Format a snapshot outside the worker lock; source state remains untouched."
+  (when value
+    (let* ((result (funcall (status-provider-formatter provider) (%copy-status-value value)))
+           (segment (etypecase result
+                      (null nil)
+                      (string (make-head-bar-segment :text result))
+                      (head-bar-segment (copy-head-bar-segment result)))))
+      (when segment
+        (setf (head-bar-segment-id segment) (status-provider-id provider)
+              (head-bar-segment-maximum-width segment)
+              (or (head-bar-segment-maximum-width segment) (status-provider-maximum-width provider))
+              (head-bar-segment-foreground segment)
+              (or (head-bar-segment-foreground segment) (status-provider-foreground provider))
+              (head-bar-segment-click-action segment)
+              (or (head-bar-segment-click-action segment) (status-provider-click-action provider)))
+        (%validate-head-bar-segment segment)))))
+
+(defun %status-worker-snapshot (worker)
+  (bt:with-lock-held ((status-worker-lock worker))
+    (%copy-status-value (status-worker-value worker))))
+
+(defun %managed-provider-segment (backend provider)
+  (let* ((runtime (x11-backend-status-runtime backend))
+         (worker (and runtime (find provider (status-runtime-workers runtime)
+                                    :key #'status-worker-provider :test #'eq))))
+    (when worker
+      (%format-status-segment provider (%status-worker-snapshot worker)))))
+
+(defun backend-status-provider-report (backend)
+  "Inspect cached status and connection errors without probing services."
+  (let ((runtime (x11-backend-status-runtime backend)))
+    (when runtime
+      (loop for worker in (status-runtime-workers runtime)
+            for provider = (status-worker-provider worker)
+            for value = (%status-worker-snapshot worker)
+            collect (let ((error (bt:with-lock-held ((status-worker-lock worker))
+                                   (status-worker-error worker)))
+                          (text nil))
+                      (handler-case
+                          (let ((segment (%format-status-segment provider value)))
+                            (when segment (setf text (head-bar-segment-text segment))))
+                        (error (condition) (setf error (princ-to-string condition))))
+                      (list :id (status-provider-id provider) :value value :text text :error error))))))

src/x11/text-native.lisp

@@ -0,0 +1,65 @@
+(in-package #:lime.x11)
+
+;;;; Narrow native boundary: no Xlib connection or toolkit event loop.
+;;;; Pango shapes UTF-8; Cairo paints memory; CLX alone uploads to X11.
+
+(cffi:define-foreign-library ui-cairo (:unix (:or "libcairo.so.2" "libcairo.so")))
+(cffi:define-foreign-library ui-pango (:unix (:or "libpango-1.0.so.0" "libpango-1.0.so")))
+(cffi:define-foreign-library ui-pangocairo (:unix (:or "libpangocairo-1.0.so.0" "libpangocairo-1.0.so")))
+(cffi:define-foreign-library ui-gobject (:unix (:or "libgobject-2.0.so.0" "libgobject-2.0.so")))
+(cffi:define-foreign-library ui-glib (:unix (:or "libglib-2.0.so.0" "libglib-2.0.so")))
+
+(defvar *text-libraries-loaded-p* nil)
+(defun %ensure-text-libraries ()
+  (unless *text-libraries-loaded-p*
+    (handler-case
+        (progn
+          (dolist (library '(ui-cairo ui-pango ui-pangocairo ui-gobject ui-glib))
+            (cffi:load-foreign-library library))
+          (setf *text-libraries-loaded-p* t))
+      (error (condition)
+        (error 'invalid-transition :description
+               (format nil "Lime fonts require Cairo and Pango (including PangoCairo): ~A" condition))))))
+
+(cffi:defcstruct pango-rectangle (x :int) (y :int) (width :int) (height :int))
+(cffi:defcstruct pango-attribute (klass :pointer) (start-index :uint) (end-index :uint))
+(cffi:defcfun ("cairo_image_surface_create" %cairo-image) :pointer (format :int) (width :int) (height :int))
+(cffi:defcfun ("cairo_surface_status" %cairo-surface-status) :int (surface :pointer))
+(cffi:defcfun ("cairo_surface_destroy" %cairo-free-surface) :void (surface :pointer))
+(cffi:defcfun ("cairo_surface_flush" %cairo-flush) :void (surface :pointer))
+(cffi:defcfun ("cairo_image_surface_get_data" %cairo-data) :pointer (surface :pointer))
+(cffi:defcfun ("cairo_image_surface_get_stride" %cairo-stride) :int (surface :pointer))
+(cffi:defcfun ("cairo_surface_write_to_png" %cairo-write-png) :int (surface :pointer) (path :string))
+(cffi:defcfun ("cairo_create" %cairo-context) :pointer (surface :pointer))
+(cffi:defcfun ("cairo_status" %cairo-status) :int (context :pointer))
+(cffi:defcfun ("cairo_destroy" %cairo-free-context) :void (context :pointer))
+(cffi:defcfun ("cairo_set_source_rgb" %cairo-rgb) :void (context :pointer) (red :double) (green :double) (blue :double))
+(cffi:defcfun ("cairo_rectangle" %cairo-rectangle) :void (context :pointer) (x :double) (y :double) (width :double) (height :double))
+(cffi:defcfun ("cairo_fill" %cairo-fill) :void (context :pointer))
+(cffi:defcfun ("cairo_clip" %cairo-clip) :void (context :pointer))
+(cffi:defcfun ("cairo_save" %cairo-save) :void (context :pointer))
+(cffi:defcfun ("cairo_restore" %cairo-restore) :void (context :pointer))
+(cffi:defcfun ("cairo_move_to" %cairo-move) :void (context :pointer) (x :double) (y :double))
+(cffi:defcfun ("pango_cairo_create_layout" %pango-layout) :pointer (context :pointer))
+(cffi:defcfun ("pango_cairo_show_layout" %pango-show) :void (context :pointer) (layout :pointer))
+(cffi:defcfun ("pango_font_description_new" %pango-description) :pointer)
+(cffi:defcfun ("pango_font_description_free" %pango-free-description) :void (description :pointer))
+(cffi:defcfun ("pango_font_description_set_family" %pango-family) :void (description :pointer) (family (:string :encoding :utf-8)))
+(cffi:defcfun ("pango_font_description_set_absolute_size" %pango-size) :void (description :pointer) (size :double))
+(cffi:defcfun ("pango_font_description_set_weight" %pango-weight) :void (description :pointer) (weight :int))
+(cffi:defcfun ("pango_layout_set_font_description" %pango-font) :void (layout :pointer) (description :pointer))
+(cffi:defcfun ("pango_layout_set_text" %pango-text) :void (layout :pointer) (text (:string :encoding :utf-8)) (length :int))
+(cffi:defcfun ("pango_attr_list_new" %pango-attr-list-new) :pointer)
+(cffi:defcfun ("pango_attr_list_unref" %pango-attr-list-unref) :void (attrs :pointer))
+(cffi:defcfun ("pango_attr_list_insert" %pango-attr-list-insert) :void (attrs :pointer) (attribute :pointer))
+(cffi:defcfun ("pango_attr_foreground_new" %pango-foreground-new) :pointer (red :uint16) (green :uint16) (blue :uint16))
+(cffi:defcfun ("pango_layout_set_attributes" %pango-set-attributes) :void (layout :pointer) (attrs :pointer))
+(cffi:defcfun ("pango_layout_set_single_paragraph_mode" %pango-single-line) :void (layout :pointer) (setting :int))
+(cffi:defcfun ("pango_layout_get_pixel_extents" %pango-extents) :void (layout :pointer) (ink :pointer) (logical :pointer))
+(cffi:defcfun ("pango_layout_get_baseline" %pango-baseline) :int (layout :pointer))
+(cffi:defcfun ("pango_layout_get_log_attrs_readonly" %pango-log-attrs) :pointer (layout :pointer) (count :pointer))
+(cffi:defcfun ("pango_layout_get_unknown_glyphs_count" %pango-unknown-glyphs) :int (layout :pointer))
+(cffi:defcfun ("pango_layout_get_line_readonly" %pango-line) :pointer (layout :pointer) (line :int))
+(cffi:defcfun ("pango_layout_line_get_x_ranges" %pango-x-ranges) :void (line :pointer) (start :int) (end :int) (ranges :pointer) (count :pointer))
+(cffi:defcfun ("g_object_unref" %g-unref) :void (object :pointer))
+(cffi:defcfun ("g_free" %g-free) :void (memory :pointer))

src/x11/text.lisp

@@ -0,0 +1,281 @@
+(in-package #:lime.x11)
+
+;;;; Shared shaping and painting policy. Bar/overlay resources belong to the
+;;;; backend thread, never to the model. All native objects have explicit owners.
+
+(defstruct ui-font-style (family "monospace") (size 14) (weight :normal))
+(defparameter *default-ui-font-style* (make-ui-font-style))
+(declaim (ftype function lime-configuration-font))
+
+(defun %configured-font (backend)
+  (declare (notinline lime-configuration-font))
+  (if (x11-backend-configuration backend)
+      (lime-configuration-font (x11-backend-configuration backend))
+      *default-ui-font-style*))
+
+(defun %validate-ui-font-style (style)
+  (unless (and (typep style 'ui-font-style)
+               (stringp (ui-font-style-family style))
+               (plusp (length (string-trim '(#\Space #\Tab) (ui-font-style-family style))))
+               (notany (lambda (c) (or (< (char-code c) 32) (<= 127 (char-code c) 159)
+                                      (member (char-code c) '(#x2028 #x2029))))
+                       (ui-font-style-family style))
+               (realp (ui-font-style-size style)) (<= 1 (ui-font-style-size style) 96)
+               (member (ui-font-style-weight style) '(:normal :bold)))
+    (error 'invalid-transition :description
+           "Font needs a nonempty family string, pixel :SIZE from 1 to 96, and :WEIGHT :NORMAL or :BOLD."))
+  style)
+
+(defstruct ui-canvas surface context width height pixels)
+(defstruct ui-text-font style canvas description layout (metrics (make-hash-table :test #'equal)))
+(defstruct text-metrics width height left top baseline ink-top ink-height boundaries unknown-glyphs)
+
+(defun %make-ui-canvas (width height)
+  (%ensure-text-libraries)
+  (let ((surface (%cairo-image 1 width height)) ; RGB24, native 32-bit pixels
+        (context nil) (success nil))
+    (unwind-protect
+         (progn
+           (unless (zerop (%cairo-surface-status surface))
+             (error "Cannot allocate UI surface ~Dx~D." width height))
+           (setf context (%cairo-context surface))
+           (unless (zerop (%cairo-status context)) (error "Cannot create UI paint context."))
+           (prog1 (make-ui-canvas :surface surface :context context :width width :height height)
+             (setf success t)))
+      (unless success
+        (when context (%cairo-free-context context))
+        (%cairo-free-surface surface)))))
+
+(defun %free-ui-canvas (canvas)
+  (when (and canvas (ui-canvas-surface canvas))
+    (%cairo-free-context (ui-canvas-context canvas))
+    (%cairo-free-surface (ui-canvas-surface canvas))
+    (setf (ui-canvas-context canvas) nil (ui-canvas-surface canvas) nil)))
+
+(defun %free-text-font (font)
+  (when font
+    (when (ui-text-font-layout font) (%g-unref (ui-text-font-layout font)))
+    (when (ui-text-font-description font) (%pango-free-description (ui-text-font-description font)))
+    (%free-ui-canvas (ui-text-font-canvas font))
+    (setf (ui-text-font-layout font) nil (ui-text-font-description font) nil)))
+
+(defun %open-text-font (style)
+  (%validate-ui-font-style style)
+  (let ((font (make-ui-text-font :style (copy-ui-font-style style))) (success nil))
+    (unwind-protect
+         (progn
+           (setf (ui-text-font-canvas font) (%make-ui-canvas 1 1)
+                 (ui-text-font-description font) (%pango-description))
+           (%pango-family (ui-text-font-description font) (ui-font-style-family style))
+           (%pango-size (ui-text-font-description font) (* 1024d0 (ui-font-style-size style)))
+           (%pango-weight (ui-text-font-description font) (if (eq :bold (ui-font-style-weight style)) 700 400))
+           (setf (ui-text-font-layout font) (%pango-layout (ui-canvas-context (ui-text-font-canvas font))))
+           (%pango-font (ui-text-font-layout font) (ui-text-font-description font))
+           (%pango-single-line (ui-text-font-layout font) 1)
+           (prog1 font (setf success t)))
+      (unless success (%free-text-font font)))))
+
+(defun %ensure-text-font (font style)
+  "Construct before releasing the old font, so a failed open keeps it alive."
+  (if (and font (equalp (ui-text-font-style font) style)) font
+      (let ((new (%open-text-font style))) (%free-text-font font) new)))
+
+(defun %ensure-ui-canvas (canvas width height)
+  (if (and canvas (= width (ui-canvas-width canvas)) (= height (ui-canvas-height canvas)))
+      canvas (let ((new (%make-ui-canvas width height))) (%free-ui-canvas canvas) new)))
+
+(defun %single-line-text (text)
+  "Preserve Unicode (including combining marks/ZWJ), but keep UI fields one line."
+  (map 'string (lambda (c)
+                 (if (or (< (char-code c) 32) (<= 127 (char-code c) 159)
+                         (member (char-code c) '(#x2028 #x2029))) #\Space c))
+       (princ-to-string text)))
+
+(defun %prepare-text (font text)
+  (%pango-text (ui-text-font-layout font) (%single-line-text text) -1))
+
+(defun %text-metrics (font text)
+  (or (gethash text (ui-text-font-metrics font))
+      (progn
+        (%prepare-text font text)
+        (cffi:with-foreign-objects ((ink '(:struct pango-rectangle)) (logical '(:struct pango-rectangle)) (count :int))
+          (%pango-extents (ui-text-font-layout font) ink logical)
+          (flet ((field (rect key) (cffi:foreign-slot-value rect '(:struct pango-rectangle) key)))
+            (let* ((left (min 0 (field ink 'x) (field logical 'x)))
+                   (top (min 0 (field ink 'y) (field logical 'y)))
+                   (right (max (+ (field ink 'x) (field ink 'width))
+                               (+ (field logical 'x) (field logical 'width))))
+                   (bottom (max (+ (field ink 'y) (field ink 'height))
+                                (+ (field logical 'y) (field logical 'height))))
+                   (attrs (%pango-log-attrs (ui-text-font-layout font) count))
+                   ;; Native guint bitfield in PangoLogAttr (Linux ABI).
+                   (cursor-bit #+little-endian 4 #-little-endian 27)
+                   (boundaries (coerce (loop for i below (cffi:mem-ref count :int)
+                                            when (logbitp cursor-bit (cffi:mem-aref attrs :uint i))
+                                              collect i) 'vector))
+                   (metrics (make-text-metrics :width (- right left) :height (- bottom top)
+                                              :left left :top top :boundaries boundaries
+                                              :baseline (round (%pango-baseline (ui-text-font-layout font)) 1024)
+                                              :ink-top (field ink 'y) :ink-height (field ink 'height)
+                                              :unknown-glyphs (%pango-unknown-glyphs (ui-text-font-layout font)))))
+              (when (>= (hash-table-count (ui-text-font-metrics font)) 256)
+                (clrhash (ui-text-font-metrics font)))
+              (setf (gethash (copy-seq text) (ui-text-font-metrics font)) metrics)))))))
+
+(defun %text-width (font text) (text-metrics-width (%text-metrics font text)))
+(defun %font-line-height (font) (max 1 (text-metrics-height (%text-metrics font "Mg"))))
+
+(defun %font-centered-baseline (font height)
+  "Center a stable letter-body sample, not font leading or each changing title.
+
+Including uppercase, lowercase ascenders, and digits captures the ordinary
+body without letting descenders move every label upward. All fields share
+this baseline; accents, descenders, and fallback glyphs keep their bearings."
+  (let ((reference (%text-metrics font "ABCabc012")))
+    (+ (floor (- height (text-metrics-ink-height reference)) 2)
+       (- (text-metrics-baseline reference) (text-metrics-ink-top reference)))))
+
+(defun %fit-text (text maximum-width measure &optional boundaries)
+  "Fit shaped text at supplied grapheme boundaries, retaining the source count."
+  (let ((string (princ-to-string text)))
+    (cond
+      ((<= maximum-width 0) (values "" 0))
+      ((<= (funcall measure string) maximum-width) (values string (length string)))
+      (t
+       (let* ((suffix (if (<= (funcall measure "...") maximum-width) "..." ""))
+              (ends (or boundaries (coerce (loop for i from 0 to (length string) collect i) 'vector)))
+              (low 0) (high (1- (length ends))))
+         (loop while (< low high)
+               for middle = (ceiling (+ low high) 2)
+               for candidate = (concatenate 'string (subseq string 0 (aref ends middle)) suffix)
+               do (if (<= (funcall measure candidate) maximum-width)
+                      (setf low middle) (setf high (1- middle))))
+         (let ((prefix (aref ends low)))
+           (values (concatenate 'string (subseq string 0 prefix) suffix) prefix)))))))
+
+(defun %fit-ui-text (font text maximum-width)
+  (let ((string (%single-line-text text)))
+    (%fit-text string maximum-width (lambda (s) (%text-width font s))
+               (text-metrics-boundaries (%text-metrics font string)))))
+
+(defun %text-prefix-ranges (font text prefix)
+  "Actual visual ranges of source text, excluding truncation dots even in RTL."
+  (when (plusp prefix)
+    (let ((metrics (%text-metrics font text)))
+      (%prepare-text font text)
+      (cffi:with-foreign-objects ((ranges :pointer) (count :int))
+        (%pango-x-ranges (%pango-line (ui-text-font-layout font) 0) 0
+                         (length (babel:string-to-octets (subseq (%single-line-text text) 0 prefix) :encoding :utf-8))
+                         ranges count)
+        (let ((data (cffi:mem-ref ranges :pointer)))
+          (unwind-protect
+               (loop for i below (cffi:mem-ref count :int)
+                     for left = (- (floor (cffi:mem-aref data :int (* 2 i)) 1024) (text-metrics-left metrics))
+                     for right = (- (ceiling (cffi:mem-aref data :int (1+ (* 2 i))) 1024) (text-metrics-left metrics))
+                     collect (cons (max 0 left) (min right (text-metrics-width metrics))))
+            (%g-free data)))))))
+
+(defun %canvas-color (canvas color)
+  (%cairo-rgb (ui-canvas-context canvas)
+              (/ (parse-integer color :start 1 :end 3 :radix 16) 255d0)
+              (/ (parse-integer color :start 3 :end 5 :radix 16) 255d0)
+              (/ (parse-integer color :start 5 :end 7 :radix 16) 255d0)))
+
+(defun %canvas-rectangle (canvas x y width height color)
+  (when (and (plusp width) (plusp height))
+    (%canvas-color canvas color)
+    (%cairo-rectangle (ui-canvas-context canvas) (float x 1d0) (float y 1d0)
+                      (float width 1d0) (float height 1d0))
+    (%cairo-fill (ui-canvas-context canvas))))
+
+(defun %text-prefix-attributes (text prefix color)
+  "Pango indexes UTF-8 bytes, while our public prefix length counts characters."
+  (let ((attrs (%pango-attr-list-new)) (success nil))
+    (unwind-protect
+         (let ((attribute (%pango-foreground-new
+                           (* 257 (parse-integer color :start 1 :end 3 :radix 16))
+                           (* 257 (parse-integer color :start 3 :end 5 :radix 16))
+                           (* 257 (parse-integer color :start 5 :end 7 :radix 16)))))
+           ;; Insertion transfers ownership to the list, including on unwind.
+           (%pango-attr-list-insert attrs attribute)
+           (setf (cffi:foreign-slot-value attribute '(:struct pango-attribute) 'start-index) 0
+                 (cffi:foreign-slot-value attribute '(:struct pango-attribute) 'end-index)
+                 (length (babel:string-to-octets
+                          (subseq (%single-line-text text) 0 (min prefix (length text)))
+                          :encoding :utf-8))
+                 success t)
+           attrs)
+      (unless success (%pango-attr-list-unref attrs)))))
+
+(defun %canvas-text (canvas font text x y width height color &key baseline (prefix-length 0) prefix-color)
+  "Paint a clipped field; BASELINE optionally aligns it to a shared row baseline.
+
+BASELINE is relative to Y. Without it, center the complete font line box.
+An optional colored prefix stays in the same shaped layout, including for RTL."
+  (when (and (plusp width) (plusp height) (plusp (length text)))
+    (let ((context (ui-canvas-context canvas)) (metrics (%text-metrics font text)) (attrs nil))
+      (%prepare-text font text)
+      (%cairo-save context)
+      (unwind-protect
+           (progn
+             (when (and prefix-color (plusp prefix-length))
+               (setf attrs (%text-prefix-attributes text prefix-length prefix-color))
+               (%pango-set-attributes (ui-text-font-layout font) attrs))
+             (%cairo-rectangle context (float x 1d0) (float y 1d0) (float width 1d0) (float height 1d0))
+             (%cairo-clip context)
+             (%canvas-color canvas color)
+             (%cairo-move context (float (- x (text-metrics-left metrics)) 1d0)
+                          (float (if baseline
+                                     (- (+ y baseline) (text-metrics-baseline metrics))
+                                     (- (+ y (floor (- height (text-metrics-height metrics)) 2))
+                                        (text-metrics-top metrics))) 1d0))
+             (%pango-show context (ui-text-font-layout font)))
+        (when attrs
+          (%pango-set-attributes (ui-text-font-layout font) (cffi:null-pointer))
+          (%pango-attr-list-unref attrs))
+        (%cairo-restore context)))))
+
+(defun %rgb-channel-to-mask (byte mask)
+  (if (zerop mask) 0
+      (let* ((shift (1- (integer-length (logand mask (- mask)))))
+             (maximum (ash mask (- shift))))
+        (ash (round (* byte maximum) 255) shift))))
+
+(defun %rgb-to-visual-pixel (pixel red green blue depth)
+  (logior (%rgb-channel-to-mask (ldb (byte 8 16) pixel) red)
+          (%rgb-channel-to-mask (ldb (byte 8 8) pixel) green)
+          (%rgb-channel-to-mask (ldb (byte 8 0) pixel) blue)
+          (logand (1- (ash 1 depth)) (lognot (logior red green blue)))))
+
+(defun %present-ui-canvas (backend canvas window gcontext)
+  "Upload an opaque frame on CLX's connection; no cross-connection races."
+  (unless (zerop (%cairo-status (ui-canvas-context canvas))) (error "UI painting failed."))
+  (%cairo-flush (ui-canvas-surface canvas))
+  (let* ((screen (x11-backend-x-screen backend))
+         (visual (xlib:screen-root-visual-info screen))
+         (depth (xlib:screen-root-depth screen))
+         (format (find depth (xlib:display-pixmap-formats (x11-backend-display backend))
+                       :key #'xlib:pixmap-format-depth))
+         (bits-per-pixel (xlib:pixmap-format-bits-per-pixel format))
+         (red (xlib:visual-info-red-mask visual)) (green (xlib:visual-info-green-mask visual))
+         (blue (xlib:visual-info-blue-mask visual))
+         (direct-p (and (= depth 24) (= red #xff0000) (= green #xff00) (= blue #xff)))
+         (data (%cairo-data (ui-canvas-surface canvas)))
+         (stride (%cairo-stride (ui-canvas-surface canvas)))
+         ;; CLX's upload array must match the server's storage, not just its
+         ;; visual depth: ordinary 24-bit visuals usually use 32-bit pixels.
+         (pixels (or (ui-canvas-pixels canvas)
+                     (setf (ui-canvas-pixels canvas)
+                           (make-array (list (ui-canvas-height canvas) (ui-canvas-width canvas))
+                                       :element-type (list 'unsigned-byte bits-per-pixel))))))
+    (unless (eq :true-color (xlib:visual-info-class visual))
+      (error 'invalid-transition :description "Lime's font renderer requires a TrueColor X11 visual."))
+    (dotimes (y (ui-canvas-height canvas))
+      (dotimes (x (ui-canvas-width canvas))
+        (let ((pixel (cffi:mem-ref data :uint32 (+ (* y stride) (* x 4)))))
+          (setf (aref pixels y x)
+                (if direct-p (logand pixel #xffffff)
+                    (%rgb-to-visual-pixel pixel red green blue depth))))))
+    (xlib:put-image window gcontext
+                    (xlib:create-image :data pixels :depth depth :bits-per-pixel bits-per-pixel)
+                    :x 0 :y 0)))

src/x11/ui-render.lisp

@@ -0,0 +1,295 @@
+(in-package #:lime.x11)
+
+;;;; X11 presentation only. Command trees/actions live in ui.lisp; navigation
+;;;; and picker/prompt transitions live in lime.ui. Geometry helpers need no X.
+
+(defstruct x11-ui-overlay
+  window font canvas foreground-gcontext head-id height hit-regions hovered-action
+  pointer-position pointer-hand-p)
+
+(defstruct ui-hit-region x y width height action)
+
+(defun %ui-hit-at (overlay x y)
+  (find-if (lambda (hit)
+             (and (<= (ui-hit-region-x hit) x)
+                  (< x (+ (ui-hit-region-x hit) (ui-hit-region-width hit)))
+                  (<= (ui-hit-region-y hit) y)
+                  (< y (+ (ui-hit-region-y hit) (ui-hit-region-height hit)))))
+           (x11-ui-overlay-hit-regions overlay)))
+
+(defun %ui-draw-hit (overlay canvas style action x y width height)
+  "Register the actual clipped paint rectangle, and highlight pointer hover."
+  (let* ((left (max 0 x)) (top (max 0 y))
+         (right (min (ui-canvas-width canvas) (+ x width)))
+         (bottom (min (ui-canvas-height canvas) (+ y height))))
+    (when (and (< left right) (< top bottom))
+      (push (make-ui-hit-region :x left :y top :width (- right left)
+                                :height (- bottom top) :action action)
+            (x11-ui-overlay-hit-regions overlay))
+      (when (let ((point (x11-ui-overlay-pointer-position overlay)))
+              (and point (<= left (car point)) (< (car point) right)
+                   (<= top (cdr point)) (< (cdr point) bottom)))
+        (setf (x11-ui-overlay-hovered-action overlay) action)
+        (%canvas-rectangle canvas left top (- right left) (- bottom top)
+                           (head-bar-style-unfocused-background style))
+        (%canvas-rectangle canvas left (1- bottom) (- right left) 1
+                           (%ui-accent-color style))))))
+
+(defun %ui-row-height (font) (max 24 (+ 8 (%font-line-height font))))
+
+(defun %ui-key-label (key)
+  (if (char= key #\Space) "SPC" (string key)))
+
+(defun %ui-menu-entries (session)
+  "Presentation data for this prefix only; descriptions stay out of the grid."
+  (append
+   (mapcar (lambda (node)
+             (list :key (%ui-key-label (ui-key-node-key node))
+                   :action (list :key (ui-key-node-key node))
+                   :label (format nil "~A~A" (if (ui-key-node-children node) "+" "")
+                                  (ui-key-node-label node))
+                   :branch-p (not (null (ui-key-node-children node)))))
+           (ui-session-key-nodes session))
+   (unless (find #\Space (ui-session-key-nodes session) :key #'ui-key-node-key)
+     (list (list :key "SPC" :label "Search commands" :action '(:key #\Space))))))
+
+(defun %ui-key-grid-layout (entries width maximum-height row-height measure &optional (page 0))
+  "A measured, paged which-key grid. Every entry fits its own clipped cell."
+  (let* ((padding (min 12 (floor width 2)))
+         (usable (max 0 (- width (* 2 padding))))
+         (gap 20)
+         (key-width (+ 8 (funcall measure "SPC →")))
+         (preferred (min 340 (max 180 (+ key-width 12
+                                        (loop for entry in entries maximize
+                                              (funcall measure (getf entry :label)) into largest
+                                              finally (return (or largest 0)))))))
+         (columns (max 1 (min 4 (floor (+ usable gap) (+ preferred gap)))))
+         (cell-width (max 0 (floor (- usable (* (1- columns) gap)) columns)))
+         (header (+ row-height 12))
+         (footer (+ row-height 8))
+         (maximum-rows (max 0 (min 6 (floor (- maximum-height header footer) row-height))))
+         (rows (min maximum-rows (max 1 (ceiling (length entries) columns))))
+         (capacity (* columns rows))
+         (pages (max 1 (ceiling (length entries) (max 1 capacity))))
+         (page (min (max 0 page) (1- pages)))
+         (start (min (length entries) (* page capacity))))
+    (list :height (max 1 (min maximum-height (+ header (* rows row-height) footer)))
+          :header-height header :footer-height footer :padding padding
+          :columns columns :rows rows :cell-width cell-width :gap gap :key-width key-width
+          :capacity capacity :page page :page-count pages
+          :start start :end (min (length entries) (+ start capacity)))))
+
+(defun %ui-visible-range (count selected capacity)
+  (let ((start (min (max 0 (- count capacity)) (max 0 (- (1+ selected) capacity)))))
+    (values start (min count (+ start capacity)))))
+
+(defun %ui-list-layout (session maximum-height row-height)
+  (let* ((header (+ row-height 12))
+         (footer (+ row-height 8))
+         (detail (if (eq (ui-session-mode session) :search) row-height 0))
+         (maximum-rows (max 0 (min 8 (floor (- maximum-height header footer detail) row-height))))
+         (rows (if (eq (ui-session-mode session) :prompt) 0
+                   (min maximum-rows (max 1 (length (ui-session-candidates session)))))))
+    (list :height (max 1 (min maximum-height (+ header (* rows row-height) detail footer)))
+          :header-height header :footer-height footer :detail-height detail :rows rows)))
+
+(defun %ui-overlay-layout (session font area)
+  (let* ((width (max 1 (x11-work-area-width area)))
+         ;; Keep the command surface a dropdown even for large/custom trees.
+         (maximum-height (max 1 (min (x11-work-area-height area)
+                                     (max 240 (floor (x11-work-area-height area) 2)))))
+         (row-height (%ui-row-height font)))
+    (if (eq (ui-session-mode session) :key-path)
+        (%ui-key-grid-layout (%ui-menu-entries session) width maximum-height row-height
+                             (lambda (text) (%text-width font text)) (ui-session-key-page session))
+        (%ui-list-layout session maximum-height row-height))))
+
+(defun %make-ui-overlay (backend head-id session)
+  (let* ((area (x11-head-work-area backend (%head-for-id backend head-id)))
+         (overlay (make-x11-ui-overlay :head-id head-id))
+         (success nil))
+    (unwind-protect
+         (progn
+           (setf (x11-ui-overlay-font overlay) (%open-text-font (%configured-font backend))
+                 (x11-ui-overlay-height overlay)
+                 (getf (%ui-overlay-layout session (x11-ui-overlay-font overlay) area) :height)
+                 (x11-ui-overlay-window overlay)
+                 (xlib:create-window
+                  :parent (x11-backend-root backend)
+                  :x (x11-work-area-x area) :y (x11-work-area-y area)
+                  :width (max 1 (x11-work-area-width area)) :height (x11-ui-overlay-height overlay)
+                  :background (xlib:screen-black-pixel (x11-backend-x-screen backend))
+                  ;; Paint the themed outline inside the canvas; no extra X
+                  ;; border outside the Head and no separate colormap allocation.
+                  :border-width 0 :override-redirect :on
+                  :event-mask '(:exposure :key-press :button-press :pointer-motion :enter-window :leave-window))
+                 (x11-ui-overlay-foreground-gcontext overlay)
+                 (xlib:create-gcontext :drawable (x11-ui-overlay-window overlay)))
+           (setf success t)
+           overlay)
+      (unless success (%free-ui-overlay overlay)))))
+
+(defun %free-ui-overlay (overlay)
+  (when overlay
+    (when (x11-ui-overlay-foreground-gcontext overlay)
+      (xlib:free-gcontext (x11-ui-overlay-foreground-gcontext overlay)))
+    (%free-text-font (x11-ui-overlay-font overlay))
+    (%free-ui-canvas (x11-ui-overlay-canvas overlay))
+    (when (x11-ui-overlay-window overlay) (xlib:destroy-window (x11-ui-overlay-window overlay)))))
+
+(defun %ui-menu-heading (session)
+  (format nil "Lime~{  ›  ~A~}"
+          (mapcar (lambda (node) (format nil "~A ~A" (%ui-key-label (ui-key-node-key node))
+                                          (ui-key-node-label node)))
+                  (ui-session-key-path session))))
+
+(defun %ui-draw-field (canvas font text x y width height color)
+  (%canvas-text canvas font (%fit-ui-text font (or text "") (max 0 width))
+                x y (max 0 width) (max 0 height) color
+                :baseline (%font-centered-baseline font height)))
+
+(defun %ui-draw-buttons (overlay canvas font style buttons left right y height)
+  "Paint right-aligned controls, returning the remaining text area's right edge.
+
+BUTTONS are (label action) pairs, rightmost first. Omit controls that cannot
+fit rather than making invisible text into a surprising click target."
+  (dolist (button buttons)
+    (let* ((label (first button)) (action (second button))
+           (width (+ 12 (%text-width font label)))
+           (x (- right width)))
+      (when (>= x left)
+        (%ui-draw-hit overlay canvas style action x y width height)
+        (%ui-draw-field canvas font label (+ x 6) y (- width 12) height
+                        (%ui-accent-color style))
+        (setf right (- x 8)))))
+  (max left right))
+
+(defun %ui-header-buttons (session)
+  (append (list (list "Close" '(:key :escape)))
+          (case (ui-session-mode session)
+            (:key-path
+             (append (list (list "Search" '(:key :tab)))
+                     (when (ui-session-key-path session)
+                       (list (list "Back" '(:key :backspace))))))
+            (:search (when (ui-session-key-root session)
+                       (list (list "Menu" '(:key :tab)))))
+            (:prompt (list (list "Confirm" '(:key :return)))))))
+
+(defun %ui-draw-key-grid (overlay canvas font session layout style)
+  (let* ((row-height (%ui-row-height font))
+         (cell-width (getf layout :cell-width))
+         (key-width (min cell-width (getf layout :key-width)))
+         (entries (%ui-menu-entries session)))
+    ;; Page navigation is session state, bounded by this font/Head's viewport.
+    (setf (ui-session-key-page session) (getf layout :page))
+    (loop for entry in (subseq entries (getf layout :start) (getf layout :end))
+          for index from 0
+          for column = (mod index (getf layout :columns))
+          for row = (floor index (getf layout :columns))
+          for x = (+ (getf layout :padding) (* column (+ cell-width (getf layout :gap))))
+          for y = (+ (getf layout :header-height) (* row row-height))
+          do (%ui-draw-hit overlay canvas style (getf entry :action) x y cell-width row-height)
+             (%ui-draw-field canvas font (format nil "~A →" (getf entry :key))
+                             x y key-width row-height (%ui-accent-color style))
+             (%ui-draw-field canvas font (getf entry :label) (+ x key-width) y
+                             (- cell-width key-width) row-height
+                             (if (getf entry :branch-p) (%ui-menu-label-color style)
+                                 (head-bar-style-foreground style))))))
+
+(defun %ui-draw-search-list (overlay canvas font session layout style width)
+  (let ((row-height (%ui-row-height font))
+        (candidates (ui-session-candidates session))
+        (selected (ui-session-selected-index session))
+        (padding (min 12 (floor width 2))))
+    (multiple-value-bind (start end) (%ui-visible-range (length candidates) selected (getf layout :rows))
+      (loop for candidate in (subseq candidates start end) for index from start
+            for top = (+ (getf layout :header-height) (* (- index start) row-height))
+            do (when (= index selected)
+                 (%canvas-rectangle canvas 4 top (max 0 (- width 8)) row-height
+                                    (head-bar-style-focused-background style))
+                 (%canvas-rectangle canvas 4 top (min 2 (max 0 (- width 4))) row-height
+                                    (%ui-accent-color style)))
+               (%ui-draw-hit overlay canvas style (list :candidate candidate)
+                             4 top (max 0 (- width 8)) row-height)
+               (%ui-draw-field canvas font (ui-candidate-label candidate) padding top
+                                (- width (* 2 padding)) row-height
+                                (if (= index selected) (head-bar-style-focused-foreground style)
+                                    (head-bar-style-foreground style))))
+      (when (and (null candidates) (plusp (getf layout :rows)))
+        (%ui-draw-field canvas font "No matching command." padding (getf layout :header-height)
+                         (- width (* 2 padding)) row-height (head-bar-style-unfocused-foreground style))))))
+
+(defun %render-command-palette (backend)
+  (let ((session (x11-backend-ui-session backend))
+        (overlay (x11-backend-ui-overlay backend)))
+    (when (and session overlay)
+      (let* ((font (setf (x11-ui-overlay-font overlay)
+                         (%ensure-text-font (x11-ui-overlay-font overlay) (%configured-font backend))))
+             (area (x11-head-work-area backend (%head-for-id backend (x11-ui-overlay-head-id overlay))))
+             (window (x11-ui-overlay-window overlay))
+             (width (max 1 (x11-work-area-width area)))
+             (layout (%ui-overlay-layout session font area))
+             (height (getf layout :height))
+             (row-height (%ui-row-height font))
+             (padding (min 12 (floor width 2)))
+             (style (%head-bar-style backend))
+             (line (or (head-bar-style-title-edge-color style) (head-bar-style-separator-color style)))
+             (canvas (setf (x11-ui-overlay-canvas overlay)
+                           (%ensure-ui-canvas (x11-ui-overlay-canvas overlay) width height))))
+        (xlib:with-state (window)
+          (setf (xlib:drawable-x window) (x11-work-area-x area)
+                (xlib:drawable-y window) (x11-work-area-y area)
+                (xlib:drawable-width window) width (xlib:drawable-height window) height))
+        (setf (x11-ui-overlay-height overlay) height
+              (x11-ui-overlay-hit-regions overlay) nil
+              (x11-ui-overlay-hovered-action overlay) nil
+              (x11-ui-overlay-pointer-position overlay) (%ui-window-pointer-position backend window))
+        (%canvas-rectangle canvas 0 0 width height (head-bar-style-background style))
+        (%canvas-rectangle canvas 0 0 width (min height (getf layout :header-height))
+                           (head-bar-style-focused-background style))
+        (let ((heading-right
+                (%ui-draw-buttons overlay canvas font style (%ui-header-buttons session)
+                                  padding (- width padding) 4
+                                  (max 0 (min row-height (- height 4))))))
+          (%ui-draw-field canvas font
+                         (case (ui-session-mode session)
+                           (:key-path (%ui-menu-heading session))
+                           (:search (format nil "Search  ~A_" (ui-session-query session)))
+                           (:prompt (format nil "~A  ~A_" (ui-session-prompt session) (ui-session-query session))))
+                         padding 4 (- heading-right padding) (max 0 (min row-height (- height 4)))
+                         (if (eq (ui-session-mode session) :key-path)
+                             (or (head-bar-style-accent-color style) (head-bar-style-foreground style))
+                             (head-bar-style-foreground style))))
+        (case (ui-session-mode session)
+          (:key-path (%ui-draw-key-grid overlay canvas font session layout style))
+          (:search (%ui-draw-search-list overlay canvas font session layout style width)))
+        (when (>= height (+ (getf layout :header-height) (getf layout :footer-height)))
+          (let* ((footer-y (- height (getf layout :footer-height)))
+                 (status (ui-session-status session))
+                 (status-right (- width padding)))
+            (%canvas-rectangle canvas padding footer-y (- width (* 2 padding)) 1 line)
+            (when (and (eq (ui-session-mode session) :search)
+                       (>= footer-y (+ (getf layout :header-height) row-height)))
+              (let ((candidate (ui-session-selected-candidate session)))
+                (%ui-draw-field canvas font (and candidate (ui-candidate-detail candidate))
+                                 padding (- footer-y row-height) (- width (* 2 padding)) row-height
+                                 (head-bar-style-unfocused-foreground style))))
+            (when (and (eq (ui-session-mode session) :key-path) (> (getf layout :page-count) 1))
+              (setf status (format nil "PgUp/PgDn ~D/~D  ·  ~A" (1+ (getf layout :page))
+                                   (getf layout :page-count) status)
+                    status-right
+                    (%ui-draw-buttons
+                     overlay canvas font style
+                     (append (when (< (getf layout :page) (1- (getf layout :page-count)))
+                               (list (list ">" '(:key :page-down))))
+                             (when (plusp (getf layout :page))
+                               (list (list "<" '(:key :page-up)))))
+                     padding status-right (+ footer-y 4) row-height)))
+            (%ui-draw-field canvas font status padding (+ footer-y 4)
+                             (- status-right padding) row-height (head-bar-style-unfocused-foreground style))))
+        (%canvas-rectangle canvas 0 (1- height) width 1 line)
+        (%present-ui-canvas backend canvas window (x11-ui-overlay-foreground-gcontext overlay))
+        (setf (x11-ui-overlay-pointer-hand-p overlay)
+              (%set-ui-pointer backend window (x11-ui-overlay-hovered-action overlay)
+                               (x11-ui-overlay-pointer-hand-p overlay)))
+        (xlib:display-force-output (x11-backend-display backend))))))