Eight Puzzle in Clojure

eight-puzzle.clj

(ns tnoda.bfs.eight-puzzle
  (:import clojure.lang.PersistentQueue)
  (:use clojure.test))

(defn- board->state
  [board]
  {:board board
   :zero (first (for [i (range 3)
                      j (range 3)
                      :when (= 0 (get-in board [i j]))]
                  [i j]))
   :history []})

(defn- initialize
  [board]
  [(->> board board->state (conj PersistentQueue/EMPTY)) #{}])

(defn- goal?
  [board]
  (= board [[1 2 3] [4 5 6] [7 8 0]]))

(defn- terminated?
  [[queue visited]]
  (if-let [state (peek queue)]
    (goal? (:board state))
    true))

(defn- swap
  [board a b]
  (-> board
      (assoc-in a (get-in board b))
      (assoc-in b (get-in board a))))

(defn- step
  [{:keys [board zero history]} direction]
  (let [[x y :as target] (map #(% %2) direction zero)]
    (when (and (<= 0 x) (<= x 2) (<= 0 y) (<= y 2))
      {:board (swap board zero target)
       :zero target
       :history (conj history direction)})))

(def ^:private directions
  [[inc identity] [identity inc] [dec identity] [identity dec]])

(defn- adjacencies
  [state]
  (keep #(step state %) directions))

(defn- search
  [[queue visited]]
  (if-let [state (peek queue)]
    [(into (pop queue) (->> state adjacencies (remove (comp visited :board))))
     (conj visited (-> state :board))]
    (throw (IllegalStateException. "The queue is empty."))))

(def ^:private direction->char
  {[identity inc] \R,
   [inc identity] \D,
   [identity dec] \L,
   [dec identity] \U})

(defn history->str [history]
  (->> history
       (map direction->char)
       (apply str)))

(defn solver
  [board]
  (->> (initialize board)
       (iterate search)
       (drop-while (comp not terminated?))
       ffirst
       peek
       :history))

(deftest test-board->state
  (is (= {:board [[1 2 3] [4 5 6] [7 8 0]], :zero [2 2], :history []}
         (board->state [[1 2 3] [4 5 6] [7 8 0]]))))

(deftest test-initialize
  (is (= [(conj PersistentQueue/EMPTY {:board [[1 2 3] [7 0 8] [4 5 6]] :zero [1 1] :history []})
          #{}]
         (initialize [[1 2 3] [7 0 8] [4 5 6]]))))

(deftest test-goal?
  (is (goal? [[1 2 3] [4 5 6] [7 8 0]]))
  (is ((comp not goal?) [[1 2 3] [4 5 6] [0 8 7]])))

(deftest test-terminated?
  (is (terminated? [PersistentQueue/EMPTY :dummy]))
  (is (terminated? (initialize [[1 2 3] [4 5 6] [7 8 0]])))
  (is ((comp not terminated?) (initialize [[0 8 7] [6 4 5] [2 1 3]]))))

(deftest test-swap
  (is (= [[2 1 3] [4 5 6] [7 8 0]] (swap [[1 2 3] [4 5 6] [7 8 0]] [0 0] [0 1]))))

(deftest test-step
  (is (= {:board [[1 0 2] [3 4 5] [6 7 8]] :zero [0 1] :history [[identity inc]]}
         (step {:board [[0 1 2] [3 4 5] [6 7 8]] :zero [0 0] :history []} [identity inc])))
  (is (nil? (step {:board [[0 1 2] [3 4 5] [6 7 8]] :zero [0 0] :history []} [dec identity]))))

(deftest test-adjacencies
  (is (= 2 (count (adjacencies {:board [[0 1 2] [3 4 5] [6 7 8]] :zero [0 0] :history []})))))

faster-eight-puzzle.clj

(ns tnoda.bfs.faster-eight-puzzle
  (:import clojure.lang.PersistentQueue)
  (:use clojure.test))

(defn- board->state
  [board]
  (let [board-array (-> board vec flatten long-array)]
    {:board board-array
     :zero (loop [i 0]
             (if (= 0 (aget ^longs board-array i))
               i
               (recur (inc i))))
     :history []}))

(defn- initialize
  [board]
  [(->> board board->state (conj PersistentQueue/EMPTY)) #{}])

(defn- hash'
  [^longs board]
  (areduce board idx ret 0 (+ (aget board idx) (* 10 ret))))

(defn- goal?
  [^longs board]
  (= 123456780 (hash' board)))

(defn- terminated?
  [[queue visited]]
  (if-let [state (peek queue)]
    (goal? (:board state))
    true))

(defn- swap
  [^longs board ^long a ^long b]
  (doto (aclone board)
    (aset a (aget board b))
    (aset b (aget board a))))

(defn- index->moves
  [idx]
  (let [x0 (quot idx 3)
        y0 (rem idx 3)]
    (->> [[-1 0] [0 1] [1 0] [0 -1]]
         (map (fn [[dx dy]]
                (let [x1 (+ x0 dx)
                      y1 (+ y0 dy)]
                  (if (and (<= 0 x1) (<= x1 2) (<= 0 y1) (<= y1 2))
                    (+ y1 (* 3 x1))
                    -1)))))))

(def ^:private moves
  (delay
    (->> (range 9)
         (map (comp long-array index->moves))
         to-array)))

(defn- step
  [{:keys [board zero history]}]
  (fn [direction]
    (let [target (aget ^longs (aget ^objects @moves zero) direction)]
      (when (<= 0 target)
        {:board (swap board zero target)
         :zero target
         :history (conj history direction)}))))

(defn- adjacencies
  [state]
  (keep (step state) (range 4)))

(defn- search
  [[queue visited]]
  (if-let [state (peek queue)]
    [(into (pop queue) (->> state adjacencies (remove (comp visited hash' :board))))
     (conj visited (-> state :board hash'))]
    (throw (IllegalStateException. "The queue is empty."))))

(defn solver
  [board]
  (->> (initialize board)
       (iterate search)
       (drop-while (comp not terminated?))
       ffirst
       peek
       :history
       (map [\U \R \D \L])
       (apply str)))

(deftest test-hash'
  (is (= 123456780 (hash' (long-array [1 2 3 4 5 6 7 8 0])))))

(deftest test-goal?
  (is (= true (goal? (long-array [1 2 3 4 5 6 7 8 0]))))
  (is (= false (goal? (long-array [0 1 2 3 4 5 6 7 8])))))

(deftest test-board->state
  (is (= 8 (-> [[1 2 3] [4 5 6] [7 8 0]] board->state :zero)))
  (is (= 5 (aget ^longs (:board (board->state [[1 2 3] [4 5 6] [7 8 0]])) 4))))

(deftest test-swap
  (is (= [2 1 3 4 5 6 7 8 0] (vec (swap (long-array [1 2 3 4 5 6 7 8 0]) 0 1)))))

(deftest test-adjacencies
  (is (= 2 (count (adjacencies {:board (long-array [0 1 2 3 4 5 6 7 8]) :zero 0 :history []})))))

(deftest test-step
  (is (= 1 (:zero (step {:board (long-array [0 1 2 3 4 5 6 7 8]) :zero 0 :history []} 1)))))

(deftest test-initialize
  (is (= 0 (-> [0 1 2 3 4 5 6 7 8] initialize first peek :zero))))

http://tnoda-clojure.tumblr.com/post/27997685895/breadth-first-search-and-eight-puzzle