Skip to content

Instantly share code, notes, and snippets.

@mharju
Created Dec 7, 2015
Embed
What would you like to do?
Megakolmio solution
(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))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment