Rush Hour puzzle solver

rush-hour.clj

(ns rush-hour)

;; We were curious what a rush how solver would look like.. and here it is. Ugly, but fast enough.
;; Solves the below expert level one in about 21 seconds on my work core i9

(def cars
  [{:car :orange
    :char "O"
    :pos [0 3]
    :size 2
    :orientation :vertical}

   {:car :dark-yellow
    :char "Y"
    :pos [0 0]
    :size 3
    :orientation :vertical}

   {:car :light-green
    :char "G"
    :pos [0 5]
    :size 2
    :orientation :horizontal}

   {:car :pink
    :char "P"
    :pos [1 1]
    :size 2
    :orientation :horizontal}

   {:car :light-blue
    :char "C"
    :pos [1 2]
    :size 2
    :orientation :vertical}

   {:car :purple
    :char "p"
    :pos [2 3]
    :size 2
    :orientation :horizontal}

   {:car :red
    :char "R"
    :pos [2 4]
    :size 2
    :orientation :vertical}

   {:car :light-purple
    :char "i"
    :pos [3 0]
    :size 3
    :orientation :horizontal}

   {:car :white
    :char "w"
    :pos [3 1]
    :size 2
    :orientation :vertical}

   {:car :green
    :char "g"
    :pos [3 4]
    :size 2
    :orentiation :vertical}

   {:car :yellow
    :char "Y"
    :pos [4 2]
    :size 2
    :orientation :horizontal}

   {:car :beige
    :char "t"
    :pos [4 3]
    :size 2
    :orientation :vertical}

   {:car :dark-blue
    :char "b"
    :pos [5 3]
    :size 3
    :orientation :vertical}])

(def board-size 6)

(def init-board
  (vec
    (for [x (range board-size)]
      (vec
        (for [y (range board-size)] " ")))))

(defn place-car [board car]
  (reduce
    (fn [b s]
      (let [coords
            (->
              (update (:pos car)
                (if (= (:orientation car) :horizontal) 0 1)
                + s)
              reverse
              vec)]
        (if (= " " (get-in b coords))
          (assoc-in b coords (or (:char car) "*"))
          (throw (RuntimeException. (str "Overlap: " (pr-str car) " with " (pr-str (get-in b coords)) " at " coords))))))
    board (range (:size car))))

(defn gen-board [cars]
  (loop [[car & other-cars] cars
         board init-board]
    (cond
      (nil? car) board

      :else
      (recur other-cars (place-car board car)))))

(defn valid-movements [path cars]
  (->>
    (map-indexed
      (fn [idx car]
        (for [shift [-1 1]]
          (let [new-pos
                (update (:pos car)
                  (if (= (:orientation car) :horizontal) 0 1)
                  + shift)]
            (when (not= new-pos (:pos car))
              (try
                (let [board
                      (gen-board
                        (assoc-in cars [idx :pos] new-pos))]
                  {:board board
                   :path (conj path (assoc car :pos new-pos :old-pos (:pos car)))
                   :new (assoc-in cars [idx :pos] new-pos)})
                (catch RuntimeException e nil))))))
      cars)
    (mapcat identity)
    (remove nil?)
    vec))

(defn describe-move [{:keys [old-pos pos car char]}]
  (str
    char " - " (name car) " "
    (cond
      (= (update-in old-pos [0] dec) pos) "Left"
      (= (update-in old-pos [0] inc) pos) "Right"
      (= (update-in old-pos [1] dec) pos) "Up"
      (= (update-in old-pos [1] inc) pos) "Down")))


(defn solve-cars [cars]
  (let [batch-size 1000]
    (loop [movements (valid-movements [] cars)
           seen-set #{}]
      
      (let [check
            (->>
              (take batch-size movements)
              (pmap (fn [c] (valid-movements (:path c) (:new c))))
              (mapcat identity)
              vec)

            match
            (first
              (filter
                (fn [c]
                  (= (:pos (first (filter #(= (:car %) :red) (:new c)))) [2 0]))
                check))]

        (println "Move: " (count movements) ", level: " (count (:path (first movements))) " - " (map (juxt :car :pos) (:path (first movements))))

        (cond
          (zero? (+ (count movements) (count check))) {:empty true}

          match
          {:startboard (gen-board cars)
           :endboard (gen-board (:new match))
           :describe
           (apply str
             (interpose "\n" (map describe-move (:path match))))}

          (> (count (:path (first check))) 100)
          {:not-found (:path (first check))}

          :else
          (recur
            (vec
              (remove
                (comp seen-set :board)
                (concat
                  (drop batch-size movements)
                  check)))
            (into seen-set (map :board check))))))))

(comment
  ;; Visualize the board
  (gen-board cars)
  
  ;; Run
  (time (solve-cars cars))  )
  

Here's what this particular puzzle looks like :) Feel free to poke around.