Megakolmio solution

core.clj

(ns megakolmio.core
  (:gen-class))

(defn match-side?
  "Check if given sides match each other"
  [s1 s2]
  (case s1
    :fox-bottom (= s2 :fox-top)
    :deer-bottom (= s2 :deer-top)
    :racoon-bottom (= s2 :racoon-top)
    :fox-top (= s2 :fox-bottom)
    :deer-top (= s2 :deer-bottom)
    :racoon-top (= s2 :racoon-bottom)))

(defn match-tile?
  "Check if the given pieces can be put together in the given final position."
  [piece-a side-a piece-b side-b pieces]
  (match-side? (nth (get pieces piece-a) side-a) (nth (get pieces piece-b) side-b)))

(defn verify-edges [solution position tile used-eqs pieces equations]
  "Verify every connected edge of the tiles in the solution"
  (map-indexed
    (fn [sym eq]
      (when-not (or (nil? eq) (nil? (get solution eq)))
        (match-tile?
          (get solution eq)
          sym
          tile
          (.indexOf (nth equations eq) position)
          pieces))) used-eqs))

(defn verify-pieces [solution pieces equations]
  "Verify all the matches of the given solution set by verifying that the specified equations hold within the set"
  (for [[position tile] solution
                        :let [eqs (nth equations position)
                             match? (verify-edges solution position tile eqs pieces equations)]]
    (every? #(or (true? %) (nil? %)) match?)))

(defn partial-solution? [solution pieces equations]
  "Check if the given solution is a partial solution for the whole puzzle i.e. is consistent within itself"
  (every? true? (verify-pieces solution pieces equations)))

(defn add-piece [solution new-position new-piece pieces equations]
  "Make a guess and verify it by trying to add the new piece to the given position."
  (if-not (some #(= (.substring (str %) 0 8) (.substring (str new-piece) 0 8)) (vals solution))
      (let [new-solution (assoc solution new-position new-piece)]
        (if (partial-solution? new-solution pieces equations) new-solution solution))
      solution))

(def num-iterations (atom 0))

(defn add-pieces-to-solution [solution current-position pieces equations remaining-pieces]
  "Adds the given pieces to the solution and verifies all of them"
  (map #(vec [% (add-piece solution current-position % pieces equations)]) remaining-pieces))

(defn filter-solutions [solution possible-solutions]
  "Filters the solutions that progress from the current state"
  (filter #(> (count (second %)) (count solution)) possible-solutions))

(defn find-solutions
  "Finds the solution of the puzzle by walking the solution graph with the given heuristics above"
  ([pieces equations walk-order] (find-solutions 0 (set (keys pieces)) {} pieces equations walk-order))
  ([walk-index remaining-pieces solution pieces equations walk-order]
    (swap! num-iterations inc)
    (if (= (count equations) (count solution))
      (into (sorted-map) solution)
      (let [current-position (nth walk-order walk-index)
          possible-solutions (->> remaining-pieces
                                  (add-pieces-to-solution solution current-position pieces equations)
                                  (filter-solutions solution))]
        (for [[used-piece next-solution] possible-solutions]
            (find-solutions (inc walk-index) (disj remaining-pieces used-piece) next-solution pieces equations walk-order))))))

(defn prune-solutions [solutions]
  "Prune solutions and only keep the unique ones"
  (into #{} (flatten solutions)))

(defn rotate
  "make a rotation from the given vector (effectively rotating degrees)"
  [piece n] (into [] (take (count piece) (drop (mod n (count piece)) (cycle piece)))))

(def solutions
  (let [pieces { :piece-1 [:fox-top :fox-bottom :deer-top] :piece-2 [:deer-top :fox-bottom :racoon-bottom]
                 :piece-3 [:deer-top :fox-bottom :fox-top] :piece-4 [:deer-top :deer-bottom :fox-bottom]
                 :piece-5 [:deer-top :racoon-bottom :deer-bottom] :piece-6 [:racoon-bottom :fox-bottom :racoon-top]
                 :piece-7 [:fox-bottom :racoon-top :fox-top] :piece-8 [:racoon-top :deer-top :racoon-bottom]
                 :piece-9 [:fox-bottom :deer-bottom :deer-top]}
        ;; Combine the given pieces with rotations of 120 and 240 degrees to get all the
        ;; pieces to use in solving the puzzle
        all-pieces (merge pieces
                      (into {} (map (fn [[k v]] [(keyword (.substring (str k "-rot-240") 1)) (doall (rotate v 1))]) pieces))
                      (into {} (map (fn [[k v]] [(keyword (.substring (str k "-rot-120") 1)) (doall (rotate v 2))]) pieces)))
        ;; Define the adjacency graph for the triangular puzzle type
        equations [[nil nil 2] [nil 2 5] [3 1 0] [2 nil 7] [nil 5 nil] [6 4 1] [5 7 nil] [8 6 3] [7 nil nil]]
        ;; Define the heuristic in which order to try to search for solutions
        ;; This is (one of many equivalent) best in that it fails most quickly
        walk-order [2 1 5 6 7 3 0 4 8]]
      (-> (find-solutions all-pieces equations walk-order) prune-solutions)))

(defn -main [& args]
  (println (str "Found " (count solutions) " unique solutions with " @num-iterations " iterations"))
  (doall
    (for [solution (sort-by (fn [s] (count (str s))) (into [] solutions))]
      (println (str "[" (clojure.string/join "," (map #(str "P" (.substring (str %) 7 8)) (vals solution))) "]"))))
  (System/exit 0))