Solution to first puzzle published in the Communications of the ACM May 2012 issue

acm-mai-p1-solution.clj

(ns acmcom-mai-puzzle.alt
  (:require [clojure.math.combinatorics :refer [subsets]]
            [clojure.set :refer [subset?]]))



(def puzzle-pieces (set (map set (reverse (subsets [:h :v :d1 :d2])))))

(def default-path (range 0 16))

(def empty-table (vec (repeat 16 #{})))


(def v-constraint-idx (memoize (fn [i]
                                 (range (rem i 4) 16 4 ))))

(def h-constraint-idx (memoize (fn [i] (let [start (- i (rem i 4))]
                                        (range start (+ start 4) )))))

(def d1-constraint-idx (memoize (fn [i]
                                  (some (fn [indices]
                                          (when (.contains indices i) indices))
                                        [ [0]
                                          [1 4]
                                          [2 5 8]
                                          [3 6 9 12]
                                          [7 10 13]
                                          [11 14]
                                          [15]]))))

(def d2-constraint-idx (memoize (fn [i]
                                  (some (fn [indices]
                                          (when (.contains indices i) indices))
                                        [[3]
                                         [2 7]
                                         [1 6 11]
                                         [0 5 10 15]
                                         [4 9 14]
                                         [8 13]
                                         [12]]))))

(def affected-positions {
                         :h h-constraint-idx
                         :v v-constraint-idx
                         :d1 d1-constraint-idx
                         :d2 d2-constraint-idx})


(defn can-place? [puzzle pos grid ]
  (when (subset? (grid pos) puzzle)
    (assoc grid pos puzzle)))

(defn add-constraint [pos grid constraint]
  (reduce (fn [grid curr-pos]
            (when grid

              (if (<= curr-pos pos)
                ;; shouldn't introduce new constraint
                (when ((grid curr-pos) constraint) grid)
                ;; simply add constraint to unoccupied fields
                (update-in grid [curr-pos] #(conj % constraint)))))
          grid
          ((affected-positions constraint) pos)))

(defn place-puzzle [puzzle pos grid]
  (when-let [new-grid (can-place? puzzle pos grid)]
    [puzzle (reduce (partial add-constraint pos) new-grid (seq puzzle))]))

(defn select-candidates [puzzles grid grid-pos]
  (->> puzzles
       (map #(when-let [puzzle-grid-pair (place-puzzle % grid-pos grid)] puzzle-grid-pair))
       (filter (fn [[puzzle new-grid]] (not (nil? new-grid))))))

(defn solve [rem-puzzles grid next-grid-pos]
  (if (> next-grid-pos 15)
    ;; we've solved it
    grid
    ;; else solve it
    (some
     (fn [ [candidate new-grid]]
       (solve (disj rem-puzzles candidate)
              new-grid
              (inc next-grid-pos)))

     (select-candidates rem-puzzles grid next-grid-pos))))

(prn (solve puzzle-pieces empty-table 0))