Keeler's Theorem: Body Swap Machine and Affine Transpositions

(defn repair-cycle
  "Keeler's blackboard formula for one cycle.
   Returns a sequence of swaps using fresh bodies :x and :y."
  [cycle]
  (let [k (count cycle)]
    (concat
      ;; swap x with each element except the last
      (map (fn [c] #{:x c}) (butlast cycle))
      ;; swap y with the last, then x with the last, then y with the first
      [#{:y (last cycle)}
       #{:x (last cycle)}
       #{:y (first cycle)}])))

(defn repair-permutation
  "Apply Keeler's theorem: decompose into cycles, repair each.
   Each cycle repair transposes x<->y. If odd number of cycles,
   x and y end up swapped — add a final [x y] to fix."
  [perm x y]
  (let [cycles (perm->cycles perm)
        swaps (vec (mapcat #(repair-cycle % x y) cycles))
        after (apply-swaps perm swaps)]
    (if (= (get after x x) y)
      (conj swaps [x y])  ;; parity correction
      swaps)))

(defn swap
  "Apply transposition {a,b} to permutation (as map)."
  [perm a b]
  (let [pa (get perm a a)
        pb (get perm b b)]
    (assoc perm a pb b pa)))

(defn perm->cycles
  "Decompose permutation (as map) into disjoint cycles."
  [perm]
  (loop [remaining (set (keys perm))
         cycles []]
    (if (empty? remaining)
      (filterv #(> (count %) 1) cycles)  ; drop fixed points
      (let [start (first remaining)
            cycle (loop [current start acc []]
                    (let [acc (conj acc current)
                          next (get perm current current)]
                      (if (= next start) acc
                          (recur next acc))))]
        (recur (reduce disj remaining cycle)
               (conj cycles cycle))))))

(defn legal?
  "Is the trace legal? Each pair used at most once."
  [trace]
  (apply distinct? trace))