clj-sudoku (backtracking)

gistfile1.clj

(ns clj-sudoku.core
  (:gen-class))

;;; Records

(defrecord Square [pos x y num hints sure unit])

;;; Grids

(def easy-grid ".931.564.7.......55.12.93.72.......3.369.752.9.......13.24.81.96.......4.473.285.")
(def medium-grid "4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......")
(def hard-grid "..............3.85..1.2.......5.7.....4...1...9.......5......73..2.1........4...9")
(def hard-grid2 "....9..5..1.....3...23..7....45...7.8.....2.......64...9..1.....8..6......54....7")
(def hard-grid3 "4...3.......6..8..........1....5..9..8....6...7.2........1.27..5.3....4.9........")
(def hard-grid4 "1.......2.9.4...5...6...7...5.9.3.......7.......85..4.7.....6...3...9.8...2.....1")

;;; Gen table

(defn- parser [e y]
  (map #(let [num (if (= \. %1) nil (Integer/parseInt (str %1)))]
          (Square. (+ (* 9 (- y 1)) %2) %2 y num (if num nil (range 1 10))
                   (if num true false) nil)) e (range 1 10)))

(defn- process [u i]
  (map (fn [a]
         (let [tmp (partition 3 a)]
           (map (fn [e c]
                  (map #(assoc % :unit c) e))
                tmp (range i (+ i 3))))) u))

(defn- make-units [sudoku]
  (let [[tu1-3 tu4-6 tu7-9] (partition 3 (partition 9 (vals (sort sudoku))))]
    (apply assoc sudoku
           (mapcat
            #(list (:pos %) %)
            (flatten
             (concat (process tu1-3 1)
                     (process tu4-6 4)
                     (process tu7-9 7)))))))

(defn- gen-sudoku [s]
  (make-units (zipmap (range 1 82)
                      (mapcat parser (partition 9 s) (range 1 10)))))

;;; Methods

(defn- valid-state? [state]
  (empty? (filter #(and (empty? (:hints %))
                       (false? (:sure %))
                       (nil? (:num %))) (vals state))))

(defn- valid-square? [square peers]
  (empty? (filter #(= (:num %) (:num square)) peers)))

(defn- clean-hints [sq num]
  (let [hints (remove #(= % num) (:hints sq))]
    (assoc sq :hints hints)))

(defn- get-peers [state square]
  (let [row (filter #(= (:y %) (:y square)) (vals state))
        col (filter #(= (:x %) (:x square)) (vals state))
        peers (filter #(= (:unit square) (:unit %)) (vals state))]
    (remove #(= % square) (flatten [row col peers]))))

(defn- new-state [state square peers]
  (let [n-state (apply assoc state
                       (mapcat #(list (:pos %) %)
                               (map #(clean-hints % (:num square)) peers)))
        n-state (assoc n-state (:pos square) square)
        n-singlets (map #(assoc % :num (first (:hints %)) :hints (list))
                        (filter #(= 1 (count (:hints %))) (vals n-state)))]
    
    (if-not (empty? n-singlets)
      (loop [state n-state
             squares n-singlets]
        (when-not (or (valid-state? state)
                      (valid-square? state square))
          nil)
        (if (empty? squares)
          state
          (recur (new-state state (first squares) (get-peers state square))
                 (rest squares))))
      
      n-state)))

(defn- few-hints-square [state]
  (let [v (vals state)
        ss (filter #(not (empty? (:hints %))) v)]
    (first (sort-by #(count (:hints %)) ss))))

(defn- complete-sures [state]
  (let [sures (filter #(true? (:sure %)) (vals state))]
    (loop [queue sures
           state state]
      (let [square (last queue)
            peers (get-peers state square)
            n-state (new-state state square peers)
            n-queue (butlast queue)]
        (if n-queue
          (recur n-queue n-state)
          n-state)))))

(defn- solve-sudoku [state]
  (let [f-st (complete-sures state)]
    (loop [queue [{:square (few-hints-square f-st)
                   :state f-st}]]
      (let [current (last queue)
            {square :square state :state} current]
        (if (:hints square)
          (let [hints (:hints square)
                nexts (reverse (map #(hash-map :square (assoc square :num % :hints nil)
                                               :state state) hints))]
            (recur (concat (butlast queue) nexts)))
          (let [peers (get-peers state square)
                n-state (new-state state square peers)
                n-square (few-hints-square n-state)]
            (if n-state
              (if n-square
                (recur (conj (butlast queue) {:square n-square
                                              :state n-state}))
                n-state)
              (recur (butlast queue)))))))))

(defn solve-grid [grid]
  (let [sudoku (gen-sudoku grid)]
    (solve-sudoku sudoku)))

(defn -main []
  (let [solution (solve-grid hard-grid4)]
    (map #(:num %) (vals (sort solution)))))

500x improvement, not fast but a lot faster than before :D