(in-package #:lime.test)

(def-suite lime-suite
  :description "Lime's Activity/View/Head/Lease model.")

(in-suite lime-suite)

(defun placements (&rest client-ids)
  (mapcar (lambda (client-id)
            (make-placement :client-id client-id))
          client-ids))

(defun make-fixture ()
  (let ((world (make-world)))
    (create-head world "left")
    (create-head world "right")
    (create-activity world "lime" "Lime development")
    (create-activity world "game" "Game")
    (create-client world "emacs" "lime" :name "Emacs")
    (create-client world "terminal" "lime" :name "Terminal")
    (create-client world "firefox" "lime" :name "Firefox")
    (create-client world "game-client" "game" :name "Game")
    (create-view world "code" "lime" "Code"
                 (placements "emacs" "terminal")
                 :focus-client-id "emacs")
    (create-view world "docs" "lime" "Docs"
                 (placements "firefox" "emacs")
                 :focus-client-id "firefox")
    (create-view world "browser" "lime" "Browser"
                 (placements "firefox")
                 :focus-client-id "firefox")
    (create-view world "play" "game" "Play"
                 (placements "game-client"))
    world))

(defun lease-head-id (world client-id)
  (let ((lease (lease-for-client world client-id)))
    (and lease
         (presentation-head-id
          (find-presentation world (lease-presentation-id lease))))))

(test views-respect-activity-ownership
  (let ((world (make-fixture)))
    (signals invalid-activity-membership
      (create-view world "bad" "lime" "Bad"
                   (placements "game-client")))))

(test an-activity-needs-no-saved-view-to-own-live-head-local-drafts
  (let ((world (make-world)))
    (create-head world "left")
    (create-head world "right")
    (create-activity world "scratch" "Scratch")
    (let ((left (open-activity-draft world "left" "scratch"))
          (right (open-activity-draft world "right" "scratch")))
      (is-false (presentation-source-view-id left))
      (is-false (presentation-source-view-id right))
      (is (eq left (activity-draft-for-head world "scratch" "left")))
      (is (eq right (activity-draft-for-head world "scratch" "right")))
      ;; Reopening an Activity resumes its one draft on that Head rather than
      ;; inventing a blank checkpoint or a second draft.
      (is (eq left (open-activity-draft world "left" "scratch")))
      (is-false (activity-view-ids (find-activity world "scratch")))
      (is-true (validate-world world)))))

(test a-default-layout-only-initializes-new-drafts
  (dolist (mode '(:manual :master-stack :monocle))
    (let ((world (make-world)))
      (create-head world "left")
      (create-head world "right")
      (create-activity world "work" "Work")
      (let* ((revision (world-revision world))
             (report (preflight-activity-draft world "left" "work" :default-layout mode)))
        (is (eq mode (activation-report-desired-layout-mode report)))
        (is (= revision (world-revision world)))
        (is-false (activity-draft-for-head world "work" "left")))
      (let ((draft (open-activity-draft world "left" "work" :default-layout mode)))
        (is (eq mode (presentation-layout-mode draft)))
        (when (eq mode :master-stack)
          (is (equal '(:master-count 1 :master-ratio 3/5 :orientation :horizontal)
                     (presentation-layout-options draft))))
        (is-false (presentation-dirty-p draft))
        (set-presentation-monocle-layout world (presentation-id draft))
        (is (eq draft (open-activity-draft world "left" "work" :default-layout :master-stack)))
        (is (eq :monocle (presentation-layout-mode draft)))
        (is (eq :monocle
                (activation-report-desired-layout-mode
                 (preflight-activity-draft world "left" "work" :default-layout :manual))))
        (is (eq mode (presentation-layout-mode
                      (open-activity-draft world "right" "work" :default-layout mode))))
        (is-true (validate-world world))
        (let ((revision (world-revision world)))
          (signals invalid-transition
            (open-activity-draft world "left" "work" :default-layout :bogus))
          (is (= revision (world-revision world))))))))

(test hiding-is-a-head-local-draft-edit-and-showing-restores-the-activity-client
  (let ((world (make-fixture)))
    (let ((presentation (activate-view-strictly world "left" "code")))
      ;; A saved View is a checkpoint, not the mutable list of every client
      ;; owned by its Activity.  Firefox begins parked for this Code draft.
      (is (equal (presentation-hidden-client-ids world presentation)
                 '("firefox")))
      (hide-focused-client-in-presentation world (presentation-id presentation))
      ;; Hiding Emacs edits only this draft.  It releases the real lease and
      ;; moves focus to Terminal, while the Activity and original Code View
      ;; remain intact for later recall.
      (is (equal (presentation-client-ids presentation) '("terminal")))
      (is (equal (presentation-hidden-client-ids world presentation)
                 '("emacs" "firefox")))
      (is-false (lease-for-client world "emacs"))
      (is (equal (presentation-focus-client-id presentation) "terminal"))
      (is (equal (mapcar #'placement-client-id
                         (view-placements (find-view world "code")))
                 '("emacs" "terminal")))
      (is-true (presentation-dirty-p presentation))
      ;; Revealing puts the client back in the live draft and acquires a
      ;; lease.  It never changes the older saved checkpoint implicitly.
      (show-client-on-presentation world "emacs" (presentation-id presentation))
      (focus-client-on-presentation world "emacs" (presentation-id presentation))
      (is (equal (presentation-client-ids presentation) '("terminal" "emacs")))
      (is (equal (presentation-hidden-client-ids world presentation)
                 '("firefox")))
      (is (equal (lease-head-id world "emacs") "left"))
      (is-true (validate-world world)))))

(test view-names-are-unique-within-an-activity-but-not-globally
  (let ((world (make-world)))
    (create-activity world "work" "Work")
    (create-activity world "chill" "Chill")
    (create-view world "work/code" "work" "Code" '())
    (signals invalid-transition
      (create-view world "work/code-2" "work" "code" '()))
    (create-view world "chill/code" "chill" "Code" '())
    (is-true (validate-world world))))

(test distinct-views-of-one-activity-can-share-the-desktop
  (let ((world (make-fixture)))
    (activate-view-strictly world "left" "code")
    (let ((right (activate-view-strictly world "right" "browser")))
      (is (equal (presentation-source-view-id right) "browser"))
      (is (equal (lease-head-id world "emacs") "left"))
      (is (equal (lease-head-id world "firefox") "right"))
      (is-true (validate-world world)))))

(test strict-preflight-is-read-only-and-reports-a-client-collision
  (let ((world (make-fixture)))
    (activate-view-strictly world "left" "code")
    (let ((report (preflight-view-activation world "right" "docs")))
      (is-false (activation-report-ready-p report))
      (is (find :client-leased
                (activation-report-conflicts report)
                :key #'activation-conflict-kind))
      (signals activation-blocked
        (build-strict-activation-plan report))
      (is (equal (lease-head-id world "emacs") "left"))
      (is-false (current-presentation world "right")))))

(test partial-activation-preserves-the-incumbent-lease
  (let ((world (make-fixture)))
    (activate-view-strictly world "left" "code")
    (let ((right (activate-view-partially world "right" "docs")))
      (is (equal (presentation-leased-client-ids world right)
                 '("firefox")))
      (is (member "emacs" (presentation-unavailable-client-ids right)
                  :test #'equal))
      (is (equal (lease-head-id world "emacs") "left"))
      (is (equal (lease-head-id world "firefox") "right"))
      (is-true (validate-world world)))))

(test taking-a-client-relocates-only-the-live-placement
  (let ((world (make-fixture)))
    (let ((left (activate-view-strictly world "left" "code")))
      (activate-view-taking world "right" "docs")
      (is (equal (lease-head-id world "emacs") "right"))
      (is-false (presentation-unavailable-client-ids left))
      (is (equal (presentation-client-ids left) '("terminal")))
      (is (equal (mapcar #'placement-client-id
                         (view-placements (find-view world "code")))
                 '("emacs" "terminal")))
      (is-true (validate-world world)))))

(test an-explicit-lease-transfer-is-a-general-command
  (let ((world (make-fixture)))
    (let ((left (activate-view-strictly world "left" "code"))
          (right (activate-view-partially world "right" "docs")))
      (transfer-client-lease world "emacs" (presentation-id right))
      (is (equal (lease-head-id world "emacs") "right"))
      (is-false (member "emacs" (presentation-client-ids left) :test #'equal))
      (is-false (member "emacs" (presentation-unavailable-client-ids right)
                        :test #'equal))
      (is-true (validate-world world)))))

(test reclaiming-is-explicit-after-a-lease-becomes-free
  (let ((world (make-fixture)))
    (activate-view-strictly world "left" "code")
    (let ((right (activate-view-partially world "right" "docs")))
      ;; Switching the left Head away releases Emacs.  It does not
      ;; spontaneously appear on the right until the user asks to reclaim it.
      (activate-view-strictly world "left" "play")
      (is-false (lease-for-client world "emacs"))
      (is (equal (reclaim-available-slots world (presentation-id right))
                 '("emacs")))
      (is (equal (lease-head-id world "emacs") "right"))
      (is-true (validate-world world)))))

(test a-named-view-cannot-be-mounted-twice
  (let ((world (make-fixture)))
    (activate-view-strictly world "left" "code")
    (let ((report (preflight-view-activation world "right" "code")))
      (is (find :view-mounted
                (activation-report-conflicts report)
                :key #'activation-conflict-kind))
      (signals activation-blocked
        (build-partial-activation-plan report)))))

(test viewsets-swap-heads-as-one-atomic-activation
  (let ((world (make-fixture)))
    (activate-view-strictly world "left" "code")
    (activate-view-strictly world "right" "play")
    (create-viewset
     world "after-work" "After work"
     (list (make-viewset-entry :head-id "left" :view-id "play")
           (make-viewset-entry :head-id "right" :view-id "code")))
    ;; Each incoming View is currently mounted on the other target Head. A
    ;; pair of ordinary one-Head commands would reject that intermediate state;
    ;; a Viewset recognizes both old Presentations as one outgoing group.
    (let* ((report (preflight-viewset-activation world "after-work"))
           (result (commit-viewset-plan world (build-strict-viewset-plan report))))
      (is-true (viewset-report-ready-p report))
      (is (equal (presentation-source-view-id
                  (current-presentation world "left"))
                 "play"))
      (is (equal (presentation-source-view-id
                  (current-presentation world "right"))
                 "code"))
      (is (equal (lease-head-id world "game-client") "left"))
      (is (equal (lease-head-id world "emacs") "right"))
      (is (equal (mapcar #'car (viewset-result-presentation-ids result))
                 '("left" "right")))
      (is-true (validate-world world)))))

(test viewsets-reuse-the-explicit-partial-and-take-lease-policies
  (let ((world (make-fixture)))
    (activate-view-strictly world "left" "browser")
    (let ((right (activate-view-strictly world "right" "code")))
      (create-viewset
       world "docs-left" "Docs on left"
       (list (make-viewset-entry :head-id "left" :view-id "docs")))
      (let ((report (preflight-viewset-activation world "docs-left")))
        (is-false (viewset-report-ready-p report))
        (is (find :client-leased (viewset-report-conflicts report)
                  :key #'viewset-conflict-kind))
        (let ((result (commit-viewset-plan world
                                           (build-partial-viewset-plan report))))
          (declare (ignore result))
          (is (equal (presentation-leased-client-ids
                      world (current-presentation world "left"))
                     '("firefox")))
          (is (member "emacs"
                      (presentation-unavailable-client-ids
                       (current-presentation world "left"))
                      :test #'equal))
          (is (equal (lease-head-id world "emacs") "right"))))
      ;; Recalling the same Viewset with :TAKE is a second deliberate command:
      ;; it moves only the contested Emacs lease and degrades the incumbent.
      (commit-viewset-plan
       world (build-taking-viewset-plan
              (preflight-viewset-activation world "docs-left")))
      (is (equal (lease-head-id world "emacs") "left"))
      (is-false (member "emacs" (presentation-client-ids right) :test #'equal))
      (is-true (validate-world world)))))

(test viewset-plans-reject-internal-window-duplication-and-staleness
  (let ((world (make-fixture)))
    (create-viewset
     world "bad-combination" "Bad combination"
     (list (make-viewset-entry :head-id "left" :view-id "code")
           ;; Code and Docs both request Emacs. A Viewset cannot pick one
           ;; merely because its entry happened to come first.
           (make-viewset-entry :head-id "right" :view-id "docs")))
    (let ((report (preflight-viewset-activation world "bad-combination")))
      (is (find :client-requested (viewset-report-conflicts report)
                :key #'viewset-conflict-kind))
      (signals activation-blocked (build-partial-viewset-plan report))
      (is-false (current-presentation world "left"))
      (is-false (current-presentation world "right")))
    (create-viewset world "valid" "Valid"
                    (list (make-viewset-entry :head-id "left" :view-id "browser")))
    (let ((plan (build-strict-viewset-plan
                 (preflight-viewset-activation world "valid"))))
      ;; Any intervening model transition invalidates a prepared whole-desk
      ;; plan; a stale command cannot replace a newly changed Head.
      (create-client world "later" "lime")
      (signals stale-transition-plan (commit-viewset-plan world plan))
      (is-false (current-presentation world "left"))
      (is-true (validate-world world)))))

(test new-windows-change-only-the-live-draft
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (create-client world "terminal-2" "lime" :name "Second terminal")
      (show-client-on-presentation world "terminal-2" (presentation-id code))
      (is (member "terminal-2" (presentation-client-ids code) :test #'equal))
      (is-false (member "terminal-2"
                        (mapcar #'placement-client-id
                                (view-placements (find-view world "code")))
                        :test #'equal))
      ;; Recalling the historical checkpoint releases the new client's lease.
      (activate-view-strictly world "left" "code")
      (is-false (lease-for-client world "terminal-2"))
      (is-true (validate-world world)))))

(test focus-is-an-explicit-active-lease-command
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (focus-client-on-presentation world "terminal" (presentation-id code))
      (is (equal (presentation-focus-client-id code) "terminal"))
      (is-true (presentation-dirty-p code))
      ;; Firefox belongs to the Activity but is not visible in this
      ;; Presentation, so selecting it must not create an implicit lease.
      (signals invalid-transition
        (focus-client-on-presentation world "firefox" (presentation-id code)))
      (is (equal (presentation-focus-client-id code) "terminal"))
      (is-true (validate-world world)))))

(test retiring-a-destroyed-client-removes-phantom-slots-everywhere
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (retire-client world "emacs")
      (signals unknown-entity (find-client world "emacs"))
      (is-false (member "emacs" (activity-client-ids (find-activity world "lime"))
                        :test #'equal))
      (is (equal (presentation-client-ids code) '("terminal")))
      ;; This Presentation began with the fallback layout, so its tree remains
      ;; implicit.  Resolving it must still have no ghost slot.
      (is (equal (mapcar #'car (resolve-presentation-layout code 800 600))
                 '("terminal")))
      (is (equal (mapcar #'placement-client-id
                         (view-placements (find-view world "code")))
                 '("terminal")))
      (is-false (lease-for-client world "emacs"))
      (is (equal (lease-head-id world "terminal") "left"))
      (is-true (validate-world world)))))

(test head-local-layouts-are-copied-and-explicitly-saved
  (let ((world (make-fixture)))
    (let ((saved-layout
            (make-layout-split
             :orientation :vertical
             :ratio 2/3
             :first (make-layout-leaf :client-id "emacs")
             :second (make-layout-leaf :client-id "terminal"))))
      (create-view world "layout" "lime" "Layout"
                   (placements "emacs" "terminal")
                   :layout-root saved-layout)
      (let ((presentation (activate-view-strictly world "left" "layout")))
        (is (equal (layout-node-client-ids
                    (presentation-layout-root presentation))
                   '("emacs" "terminal")))
        (is-false (eq saved-layout (presentation-layout-root presentation)))
        (set-presentation-layout-root
         world
         (presentation-id presentation)
         (make-layout-split
          :orientation :horizontal
          :ratio 1/2
          :first (make-layout-leaf :client-id "emacs")
          :second (make-layout-leaf :client-id "terminal")))
        (is (eq (layout-split-orientation
                 (presentation-layout-root presentation))
                :horizontal))
        ;; The checkpoint remains vertical until the user explicitly updates it.
        (is (eq (layout-split-orientation
                 (view-layout-root (find-view world "layout")))
                :vertical))
        (update-view-from-presentation world "layout" (presentation-id presentation))
        (is (eq (layout-split-orientation
                 (view-layout-root (find-view world "layout")))
                :horizontal))
        (is-true (validate-world world))))))

(test master-stack-is-a-head-local-saved-layout-policy
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (show-client-on-presentation world "firefox" (presentation-id code))
      (set-presentation-master-stack-layout
       world (presentation-id code) :master-count 1 :master-ratio 3/5)
      (is (eq (presentation-layout-mode code) :master-stack))
      (is (equal (presentation-layout-options code)
                 '(:master-count 1 :master-ratio 3/5 :orientation :horizontal)))
      (is (equal (layout-node-client-ids (presentation-layout-root code))
                 '("emacs" "terminal" "firefox")))
      (let ((layout (resolve-presentation-layout code 1000 600)))
        (let ((master (cdr (assoc "emacs" layout :test #'equal)))
              (first-stack (cdr (assoc "terminal" layout :test #'equal)))
              (second-stack (cdr (assoc "firefox" layout :test #'equal))))
          (is (= (geometry-width master) 600))
          (is (= (geometry-width first-stack) 400))
          (is (= (geometry-y first-stack) 0))
          (is (= (geometry-y second-stack) 300))))
      ;; The policy follows the live draft as clients arrive and persists only
      ;; when explicitly checkpointed.
      (create-client world "terminal-2" "lime")
      (show-client-on-presentation world "terminal-2" (presentation-id code))
      (is (equal (layout-node-client-ids (presentation-layout-root code))
                 '("emacs" "terminal" "firefox" "terminal-2")))
      (update-view-from-presentation world "code" (presentation-id code))
      (is (eq (view-layout-mode (find-view world "code")) :master-stack))
      (is-true (validate-world world)))))

(test master-stack-weights-resize-each-column-independently-on-both-axes
  (let* ((world (make-fixture))
         (code (activate-view-strictly world "left" "code"))
         (id (presentation-id code)))
    (show-client-on-presentation world "firefox" id)
    (dolist (client '("extra-1" "extra-2"))
      (create-client world client "lime")
      (show-client-on-presentation world client id))
    (set-presentation-master-stack-layout world id :master-count 2 :master-ratio 3/5)
    (set-client-tile-weight world id "terminal" 2)
    (set-client-tile-weight world id "firefox" 2)
    (flet ((geometry (client layout) (cdr (assoc client layout :test #'equal))))
      (let ((layout (resolve-presentation-layout code 1000 600)))
        ;; Master weights 1:2; stack weights 2:1:1. Neither changes column width.
        (is (= 200 (geometry-height (geometry "emacs" layout))))
        (is (= 400 (geometry-height (geometry "terminal" layout))))
        (is (= 300 (geometry-height (geometry "firefox" layout))))
        (is (= 150 (geometry-height (geometry "extra-1" layout))))
        (is (= 150 (geometry-height (geometry "extra-2" layout))))
        (is (= 600 (geometry-width (geometry "terminal" layout))))
        (is (= 400 (geometry-width (geometry "firefox" layout)))))
      (set-presentation-master-stack-layout world id :master-count 2
                                           :master-ratio 1/2 :orientation :vertical)
      (let ((layout (resolve-presentation-layout code 600 1000)))
        (is (= 200 (geometry-width (geometry "emacs" layout))))
        (is (= 400 (geometry-width (geometry "terminal" layout))))
        (is (= 300 (geometry-width (geometry "firefox" layout))))
        (is (= 150 (geometry-width (geometry "extra-1" layout))))
        (is (= 150 (geometry-width (geometry "extra-2" layout))))
        (is (= 500 (geometry-height (geometry "firefox" layout))))))
    (is (equal "emacs" (presentation-focus-client-id code)))
    (is-true (validate-world world))))

(test tile-weights-follow-the-window-through-reordering-and-reflow
  (let* ((world (make-fixture))
         (code (activate-view-strictly world "left" "code"))
         (id (presentation-id code)))
    (show-client-on-presentation world "firefox" id)
    (set-presentation-master-stack-layout world id :master-ratio 3/5)
    (set-client-tile-weight world id "terminal" 2)
    (focus-client-on-presentation world "terminal" id)
    (swap-focused-layout-client world id)
    (is (eq :master-stack (presentation-layout-mode code)))
    (is (equal '("emacs" "firefox" "terminal") (presentation-client-ids code)))
    (let ((tile (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
                            :test #'equal))))
      (is (= 200 (geometry-y tile)))
      (is (= 400 (geometry-height tile))))
    (create-client world "extra" "lime")
    (show-client-on-presentation world "extra" id)
    (is (= 300 (geometry-height
                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
                            :test #'equal)))))
    (retire-client world "extra")
    (is (= 400 (geometry-height
                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
                            :test #'equal)))))
    (hide-client-from-presentation world "firefox" id)
    ;; A sole window fills its column, with its weight retained for future peers.
    (is (= 600 (geometry-height
                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
                            :test #'equal)))))
    (show-client-on-presentation world "firefox" id)
    (is (= 400 (geometry-height
                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
                            :test #'equal)))))
    (is-true (validate-world world))))

(test tile-weights-survive-floating-resizing-and-layout-changes
  (let* ((world (make-fixture))
         (code (activate-view-strictly world "left" "code"))
         (id (presentation-id code)))
    (show-client-on-presentation world "firefox" id)
    (set-presentation-master-stack-layout world id)
    (set-client-tile-weight world id "terminal" 2)
    (toggle-client-floating world id "terminal")
    (set-client-floating-geometry world id "terminal" :width 1/2)
    (update-view-from-presentation world "code" id)
    ;; Float checkpoint copies must preserve the dormant tiling weight too.
    (setf code (activate-view-strictly world "left" "code")
          id (presentation-id code))
    (toggle-client-floating world id "terminal")
    (set-presentation-monocle-layout world id)
    (set-presentation-manual-layout world id)
    (set-presentation-master-stack-layout world id)
    (is (= 400 (geometry-height
                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
                            :test #'equal)))))
    (is-true (validate-world world))))

(test tile-weights-are-independent-view-checkpoints-and-head-local-edits
  (let* ((world (make-fixture))
         (code (activate-view-strictly world "left" "code"))
         (id (presentation-id code))
         (right (activate-view-strictly world "right" "browser")))
    (set-presentation-master-stack-layout world id :master-count 2)
    (set-client-tile-weight world id "terminal" 2)
    (let ((saved (find "terminal" (view-placements (find-view world "code"))
                       :key #'placement-client-id :test #'equal)))
      (is (= 1 (placement-tile-weight saved))))
    (update-view-from-presentation world "code" id)
    (set-client-tile-weight world id "terminal" 1)
    (is-true (presentation-dirty-p code))
    (is (= 300 (geometry-height
                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
                            :test #'equal)))))
    (setf code (activate-view-strictly world "left" "code"))
    (is (= 400 (geometry-height
                (cdr (assoc "terminal" (resolve-presentation-layout code 1000 600)
                            :test #'equal)))))
    (is-false (presentation-dirty-p code))
    (is (eq right (current-presentation world "right")))
    (is-false (presentation-dirty-p right))
    (is (equal "right" (lease-head-id world "firefox")))
    (is-true (validate-world world))))

(test invalid-tile-weight-edits-leave-the-draft-intact
  (let* ((world (make-fixture))
         (code (activate-view-strictly world "left" "code"))
         (id (presentation-id code)))
    (set-presentation-master-stack-layout world id)
    (let ((revision (world-revision world))
          (root (presentation-layout-root code)))
      (dolist (weight '(0 -1 nope))
        (signals invalid-transition (set-client-tile-weight world id "terminal" weight)))
      (signals invalid-transition (set-client-tile-weight world id "firefox" 2))
      (is (= revision (world-revision world)))
      (is (eq root (presentation-layout-root code))))
    (toggle-client-floating world id "terminal")
    (let ((revision (world-revision world)))
      (signals invalid-transition (set-client-tile-weight world id "terminal" 2))
      (is (= revision (world-revision world))))
    (set-presentation-monocle-layout world id)
    (let ((revision (world-revision world)))
      (signals invalid-transition (set-client-tile-weight world id "emacs" 2))
      (is (= revision (world-revision world))))
    (signals invalid-transition
      (create-view world "bad-weight" "lime" "Bad weight"
                   (list (make-placement :client-id "firefox" :data '(:tile-weight 0)))))
    (signals invalid-transition
      (master-stack-layout-root '("a" "b") :weights '(1)))
    (signals invalid-transition
      (master-stack-layout-root '("a" "b") :weights '(1 -1)))
    (is-true (validate-world world))))

(test master-stack-client-flow-honors-insertion-and-focus-policy
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (set-presentation-master-stack-layout world (presentation-id code)
                                           :master-count 1 :master-ratio 3/5)
      ;; :BACK is the familiar dwm-like behavior: the newcomer is focused but
      ;; every existing master/stack slot stays put and it joins at the
      ;; visual bottom of the stack.
      (show-client-on-presentation world "firefox" (presentation-id code)
                                   :tiled-insertion-position :back :focus-p t)
      (is (equal (presentation-client-ids code)
                 '("emacs" "terminal" "firefox")))
      (is (equal (presentation-focus-client-id code) "firefox"))
      (let ((layout (resolve-presentation-layout code 1000 600)))
        (is (= (geometry-y (cdr (assoc "firefox" layout :test #'equal))) 300)))
      ;; Placement order points from master toward the bottom of the stack,
      ;; so closing the focused lowest client with :PREVIOUS focuses Terminal.
      (retire-client world "firefox" :focus-direction :previous)
      (is (equal (presentation-focus-client-id code) "terminal"))
      ;; The same engine also admits a different user policy without changing
      ;; the master/stack implementation itself: :FRONT creates a new master.
      (create-client world "browser-2" "lime")
      (show-client-on-presentation world "browser-2" (presentation-id code)
                                   :tiled-insertion-position :front :focus-p t)
      (is (equal (presentation-client-ids code)
                 '("browser-2" "emacs" "terminal")))
      (is (equal (presentation-focus-client-id code) "browser-2"))
      (retire-client world "browser-2" :focus-direction :previous)
      ;; There is nothing before master, so the opposite direction is the
      ;; graceful edge fallback.
      (is (equal (presentation-focus-client-id code) "emacs"))
      (is-true (validate-world world)))))

(test monocle-client-flow-makes-new-clients-the-current-cycle-entry
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (set-presentation-monocle-layout world (presentation-id code))
      ;; In monocle placement order is the cycle below the visible client. A
      ;; newcomer therefore goes first and becomes the one full-screen tile.
      (show-client-on-presentation world "firefox" (presentation-id code)
                                   :tiled-insertion-position :front :focus-p t)
      (is (equal (presentation-client-ids code)
                 '("firefox" "emacs" "terminal")))
      (is (equal (presentation-focus-client-id code) "firefox"))
      (is (equal (mapcar #'car (resolve-presentation-layout code 800 600))
                 '("firefox")))
      ;; The next client in that order is the natural close target.  Exercise
      ;; RETIRE-CLIENT's per-container policy hook, used by the X11 adapter.
      (retire-client world "firefox"
                     :focus-direction (lambda (container)
                                        (declare (ignore container))
                                        :next))
      (is (equal (presentation-focus-client-id code) "emacs"))
      (is (equal (mapcar #'car (resolve-presentation-layout code 800 600))
                 '("emacs")))
      (is-true (validate-world world)))))

(test monocle-renders-only-the-focused-tiled-client
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (set-presentation-monocle-layout world (presentation-id code))
      (is (eq (presentation-layout-mode code) :monocle))
      (let ((layout (resolve-presentation-layout code 800 600)))
        (is (equal (mapcar #'car layout) '("emacs")))
        (is (= (geometry-width (cdar layout)) 800)))
      (focus-client-on-presentation world "terminal" (presentation-id code))
      (is (equal (mapcar #'car (resolve-presentation-layout code 800 600))
                 '("terminal")))
      (is-true (validate-world world)))))

(test floating-placements-have-normalized-geometry-and-rejoin-tiling
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (toggle-focused-client-floating world (presentation-id code))
      (let ((placement (find "emacs" (presentation-placements code)
                             :key #'placement-client-id :test #'equal)))
        (is (eq (placement-kind placement) :float))
        (is (equal (placement-data placement)
                   '(:x 1/8 :y 1/8 :width 3/4 :height 3/4))))
      ;; The float is independent of the tiled fallback tree and is resolved
      ;; after tiled content so a renderer may keep it above the tiles.
      (let ((layout (resolve-presentation-layout code 800 600)))
        (is (equal (mapcar #'car layout) '("terminal" "emacs")))
        (let ((float (cdr (assoc "emacs" layout :test #'equal)))
              (tile (cdr (assoc "terminal" layout :test #'equal))))
          (is (= (geometry-x float) 100))
          (is (= (geometry-y float) 75))
          (is (= (geometry-width float) 600))
          (is (= (geometry-height float) 450))
          (is (= (geometry-width tile) 800))))
      (set-client-floating-geometry world (presentation-id code) "emacs"
                                    :x 1/4 :y 1/5 :width 1/2 :height 2/5)
      (let ((float (cdr (assoc "emacs"
                               (resolve-presentation-layout code 800 600)
                               :test #'equal))))
        (is (= (geometry-x float) 200))
        (is (= (geometry-y float) 120))
        (is (= (geometry-width float) 400))
        (is (= (geometry-height float) 240)))
      (toggle-client-floating world (presentation-id code) "emacs")
      (let ((placement (find "emacs" (presentation-placements code)
                             :key #'placement-client-id :test #'equal)))
        (is (eq (placement-kind placement) :tile))
        (is-false (placement-data placement)))
      (is (equal (mapcar #'car (resolve-presentation-layout code 800 600))
                 '("emacs" "terminal")))
      (is-true (validate-world world)))))

(test floating-geometry-is-an-explicitly-saved-head-local-checkpoint-change
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (toggle-client-floating world (presentation-id code) "terminal"
                              :data '(:x 1/5 :y 1/6 :width 1/2 :height 1/2))
      ;; The named checkpoint remains tiled until the user asks to update it.
      (is (eq (placement-kind
               (find "terminal" (view-placements (find-view world "code"))
                     :key #'placement-client-id :test #'equal))
              :tile))
      (update-view-from-presentation world "code" (presentation-id code))
      (let ((saved (find "terminal" (view-placements (find-view world "code"))
                         :key #'placement-client-id :test #'equal)))
        (is (eq (placement-kind saved) :float))
        (is (equal (placement-data saved)
                   '(:x 1/5 :y 1/6 :width 1/2 :height 1/2))))
      (set-client-floating-geometry world (presentation-id code) "terminal"
                                    :x 1/4)
      (is (equal (placement-data
                  (find "terminal" (view-placements (find-view world "code"))
                        :key #'placement-client-id :test #'equal))
                 '(:x 1/5 :y 1/6 :width 1/2 :height 1/2)))
      (is-true (validate-world world)))))

(test master-stack-reflows-when-a-client-enters-or-leaves-floating
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (show-client-on-presentation world "firefox" (presentation-id code))
      (set-presentation-master-stack-layout world (presentation-id code)
                                           :master-count 1 :master-ratio 3/5)
      (toggle-client-floating world (presentation-id code) "terminal")
      (is (eq (presentation-layout-mode code) :master-stack))
      (is (equal (layout-node-client-ids (presentation-layout-root code))
                 '("emacs" "firefox")))
      (let ((layout (resolve-presentation-layout code 1000 600)))
        (is (= (geometry-width (cdr (assoc "emacs" layout :test #'equal))) 600))
        (is (= (geometry-width (cdr (assoc "firefox" layout :test #'equal))) 400))
        (is (= (geometry-width (cdr (assoc "terminal" layout :test #'equal)))
               750)))
      (toggle-client-floating world (presentation-id code) "terminal")
      (is (equal (layout-node-client-ids (presentation-layout-root code))
                 '("emacs" "terminal" "firefox")))
      (is-true (validate-world world)))))

(test manual-layout-commands-edit-the-focused-nearest-split
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (adjust-focused-layout-split-ratio world (presentation-id code) 1/10)
      (is (eq (presentation-layout-mode code) :manual))
      (is (= (layout-split-ratio (presentation-layout-root code)) 3/5))
      (set-focused-layout-split-orientation world (presentation-id code)
                                            :vertical)
      (is (eq (layout-split-orientation (presentation-layout-root code))
              :vertical))
      (swap-focused-layout-client world (presentation-id code))
      (is (equal (layout-node-client-ids (presentation-layout-root code))
                 '("terminal" "emacs")))
      (is-true (validate-world world)))))

(test promoting-a-client-creates-a-master-stack-draft
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (show-client-on-presentation world "firefox" (presentation-id code))
      (focus-client-on-presentation world "terminal" (presentation-id code))
      (promote-client-to-master world (presentation-id code) "terminal")
      (is (eq (presentation-layout-mode code) :master-stack))
      (is (equal (layout-node-client-ids (presentation-layout-root code))
                 '("terminal" "emacs" "firefox")))
      (is (equal (mapcar #'placement-client-id
                         (presentation-placements code))
                 '("terminal" "emacs" "firefox")))
      (is-true (validate-world world)))))

(test resuming-a-cached-presentation-preserves-its-draft
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (create-client world "terminal-2" "lime")
      (show-client-on-presentation world "terminal-2" (presentation-id code))
      (activate-view-strictly world "left" "play")
      (let ((resumed (resume-presentation-strictly world "left"
                                                    (presentation-id code))))
        (is (eq code resumed))
        (is (member "terminal-2" (presentation-client-ids resumed)
                    :test #'equal))
        (is (equal (lease-head-id world "terminal-2") "left"))
        (is-true (presentation-dirty-p resumed))
        (is-true (validate-world world))))))

(test resume-keeps-current-locations-instead-of-recalling-checkpoint-requests
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (activate-view-strictly world "left" "play")
      (activate-view-strictly world "right" "docs")
      (let ((report (preflight-presentation-resume world "left"
                                                    (presentation-id code))))
        (is (activation-report-ready-p report))
        (is (equal '("terminal") (mapcar #'placement-client-id (activation-report-desired-placements report)))))
      (let ((resumed (resume-presentation-strictly world "left"
                                                     (presentation-id code))))
        (is (eq code resumed))
        (is-false (presentation-unavailable-client-ids resumed))
        (is (equal (lease-head-id world "terminal") "left"))
        (is (equal (lease-head-id world "emacs") "right"))
        (is-true (validate-world world))))))

(test updating-a-view-is-explicit
  (let ((world (make-fixture)))
    (let ((code (activate-view-strictly world "left" "code")))
      (create-client world "terminal-2" "lime")
      (show-client-on-presentation world "terminal-2" (presentation-id code))
      (update-view-from-presentation world "code" (presentation-id code))
      (is (member "terminal-2"
                  (mapcar #'placement-client-id
                          (view-placements (find-view world "code")))
                  :test #'equal))
      (is-false (presentation-dirty-p code)))))

(test a-degraded-presentation-cannot-silently-overwrite-a-view
  (let ((world (make-fixture)))
    (activate-view-strictly world "left" "code")
    (let ((right (activate-view-partially world "right" "docs")))
      (signals degraded-presentation-update
        (update-view-from-presentation world "docs" (presentation-id right))))))

(test topology-reconciliation-moves-a-removed-heads-live-draft-intact
  (let ((world (make-fixture)))
    (let* ((code (activate-view-strictly world "left" "code"))
           (browser (activate-view-strictly world "right" "browser"))
           (report (preflight-head-topology-reconciliation world
                                                             '("left" "dock"))))
      (is (equal (head-topology-report-added-head-ids report) '("dock")))
      (is (equal (head-topology-report-removed-head-ids report) '("right")))
      (is (equal (mapcar #'head-topology-source-presentation-id
                         (head-topology-report-removed-active-sources report))
                 (list (presentation-id browser))))
      (let ((result
              (commit-head-topology-reconciliation-plan
               world
               (build-head-topology-reconciliation-plan
                report
                :moves (list (make-head-topology-move
                              :from-head-id "right" :to-head-id "dock"))))))
        (is (equal (head-topology-result-moved-presentation-ids result)
                   (list (presentation-id browser))))
        (is (eq (current-presentation world "left") code))
        (is (eq (current-presentation world "dock") browser))
        (is (equal (presentation-head-id browser) "dock"))
        (is (equal (lease-head-id world "firefox") "dock"))
        (signals unknown-entity (find-head world "right"))
        (is-true (validate-world world))))))

(test topology-reconciliation-suspends-an-unmoved-draft-and-allows-rehoming
  (let ((world (make-fixture)))
    (activate-view-strictly world "left" "code")
    (let* ((browser (activate-view-strictly world "right" "browser"))
           (remove-report (preflight-head-topology-reconciliation world '("left")))
           (result
             (commit-head-topology-reconciliation-plan
              world (build-head-topology-reconciliation-plan remove-report))))
      (is (equal (head-topology-result-suspended-presentation-ids result)
                 (list (presentation-id browser))))
      (is-false (presentation-head-id browser))
      (is-false (lease-for-client world "firefox"))
      (let ((add-report
              (preflight-head-topology-reconciliation world '("left" "laptop"))))
        (commit-head-topology-reconciliation-plan
         world (build-head-topology-reconciliation-plan add-report)))
      (let ((resumed (resume-presentation-strictly world "laptop"
                                                    (presentation-id browser))))
        (is (eq resumed browser))
        (is (equal (presentation-head-id browser) "laptop"))
        (is (equal (lease-head-id world "firefox") "laptop"))
        (is-true (validate-world world))))))

(test topology-reconciliation-rejects-ambiguous-destinations-without-mutation
  (let ((world (make-fixture)))
    (create-head world "third")
    (activate-view-strictly world "left" "code")
    (activate-view-strictly world "right" "browser")
    (activate-view-strictly world "third" "play")
    (let ((report (preflight-head-topology-reconciliation world '("left"))))
      (signals invalid-transition
        (build-head-topology-reconciliation-plan
         report
         :moves (list (make-head-topology-move :from-head-id "right"
                                                :to-head-id "left")
                      (make-head-topology-move :from-head-id "third"
                                                :to-head-id "left"))))
      (is (current-presentation world "right"))
      (is (current-presentation world "third"))
      (is-true (validate-world world)))))

(test stale-plans-cannot-overwrite-newer-state
  (let ((world (make-fixture)))
    (let* ((report (preflight-view-activation world "left" "code"))
           (plan (build-strict-activation-plan report)))
      (create-client world "terminal-2" "lime")
      (signals stale-transition-plan
        (commit-activation-plan world plan))
      (is-false (current-presentation world "left")))))

(test activity-is-one-live-arrangement-across-independently-selected-heads
  (let* ((world (make-fixture))
         (left (open-activity-draft world "left" "lime" :default-layout :master-stack))
         (right (open-activity-draft world "right" "lime" :default-layout :monocle)))
    (show-client-on-presentation world "emacs" (presentation-id left))
    (show-client-on-presentation world "firefox" (presentation-id right))
    (set-presentation-layout-mode world (presentation-id left) :master-stack :layout-options '(:master-ratio 2/3))
    (dotimes (i 3)
      (open-activity-draft world "right" "game")
      (is (equal "left" (lease-head-id world "emacs")))
      (is-false (lease-for-client world "firefox"))
      (open-activity-draft world "left" "game")
      (is-false (lease-for-client world "emacs"))
      ;; Return in either order, independently. No save/recall or policy choice.
      (dolist (head (if (evenp i) '("right" "left") '("left" "right")))
        (is (activation-report-ready-p (preflight-activity-draft world head "lime")))
        (open-activity-draft world head "lime"))
      (is (eq left (current-presentation world "left")))
      (is (eq right (current-presentation world "right")))
      (is (equal "left" (lease-head-id world "emacs")))
      (is (equal "right" (lease-head-id world "firefox"))))
    (is (= 2/3 (getf (presentation-layout-options left) :master-ratio)))
    (is (eq :monocle (presentation-layout-mode right)))
    ;; Explicit relocation changes the source even after another round trip.
    (show-client-on-presentation world "firefox" (presentation-id left))
    (transfer-client-lease world "firefox" (presentation-id left))
    (is-false (presentation-client-ids right))
    (open-activity-draft world "right" "game")
    (open-activity-draft world "right" "lime")
    (is-false (presentation-client-ids right))
    (is (equal "left" (lease-head-id world "firefox")))
    ;; Hiding does not resurface through another arrangement or a return.
    (hide-client-from-presentation world "firefox" (presentation-id left))
    (open-activity-draft world "left" "game")
    (open-activity-draft world "left" "lime")
    (is-false (lease-for-client world "firefox"))
    (is (equal '("emacs") (presentation-client-ids left)))
    (is-true (validate-world world))))

(test first-visit-to-inactive-activity-does-not-gather-other-heads-windows
  (let* ((world (make-fixture)) (left (open-activity-draft world "left" "lime")))
    (show-client-on-presentation world "emacs" (presentation-id left))
    (open-activity-draft world "left" "game")
    (is-false (presentation-client-ids (open-activity-draft world "right" "lime")))
    (is-false (lease-for-client world "emacs"))
    ;; Summoning a not-currently-visible client also updates its old location.
    (show-client-on-presentation world "emacs" (presentation-id (current-presentation world "right")))
    (is-false (presentation-client-ids left))
    (open-activity-draft world "left" "lime")
    (is (equal "right" (lease-head-id world "emacs")))
    (is-true (validate-world world))))

(test checkpoints-edit-one-working-arrangement-without-creating-hidden-workspaces
  (let* ((world (make-fixture)) (left (open-activity-draft world "left" "lime")))
    (activate-view-strictly world "left" "code")
    (is (eq left (current-presentation world "left")))
    (hide-client-from-presentation world "emacs" (presentation-id left))
    (open-activity-draft world "left" "game")
    (is (eq left (open-activity-draft world "left" "lime")))
    (is (equal '("terminal") (presentation-client-ids left)))
    (activate-view-strictly world "left" "code")
    (is (equal '("emacs" "terminal") (presentation-client-ids left)))
    (is-false (presentation-dirty-p left))
    ;; Recalling the checkpoint elsewhere while the old side is inactive
    ;; changes live locations and detaches its old source label, not the View.
    (open-activity-draft world "left" "game")
    (activate-view-strictly world "right" "code")
    (is-false (presentation-source-view-id left))
    (is-false (presentation-client-ids left))
    (open-activity-draft world "left" "lime")
    (is (equal "right" (lease-head-id world "emacs")))
    (is (= 2 (length (view-placements (find-view world "code")))))
    (is-true (validate-world world))))

(test partially-recalled-view-does-not-retry-missing-windows-on-activity-return
  (let* ((world (make-fixture))
         (left (activate-view-strictly world "left" "code"))
         (right (activate-view-partially world "right" "docs")))
    (is (equal '("emacs") (presentation-unavailable-client-ids right)))
    (open-activity-draft world "right" "game")
    (open-activity-draft world "left" "game")
    (open-activity-draft world "right" "lime")
    (is-false (lease-for-client world "emacs"))
    (is (equal '("firefox") (presentation-client-ids right)))
    (open-activity-draft world "left" "lime")
    (is (eq left (current-presentation world "left")))
    (is (equal "left" (lease-head-id world "emacs")))
    (is-true (validate-world world))))

(defun run-tests ()
  (run! 'lime-suite))