Skip to content

Instantly share code, notes, and snippets.

@jkk
Created March 28, 2011 21:08
Show Gist options
  • Save jkk/891288 to your computer and use it in GitHub Desktop.
Save jkk/891288 to your computer and use it in GitHub Desktop.
;;;; Translation of Peter Norvig's sudoku solver to idiomatic Clojure
;;;; See http://norvig.com/sudoku.html
;;;;
;;;; Throughout this program we have:
;;;; r is a row, e.g. :a
;;;; c is a column, e.g. 3
;;;; s is a square, e.g. [:a 3]
;;;; d is a digit, e.g. 9
;;;; u is a unit, e.g. [[:a 1] [:b 1] [:c 1] ... [:i 1]]
;;;; grid is a grid, e.g. 81 non-blank chars, e.g. starting with ".18...7..."
;;;; values is a map of possible values, e.g. {[:a 1] #{1 2 3 9} [:a 2] #{8}}
(ns user
(:use [clojure.string :only [join trim]]))
(def digits (set (range 1 10)))
(def rows [:a :b :c :d :e :f :g :h :i])
(def cols (range 1 10))
(def squares (for [r rows c cols] [r c]))
(def unitlist (concat (for [c cols] (for [r rows] [r c]))
(for [r rows] (for [c cols] [r c]))
(for [rs (partition 3 rows) cs (partition 3 cols)]
(for [r rs c cs] [r c]))))
(def units (into {} (for [s squares]
[s (for [u unitlist :when (some #{s} u)] u)])))
(def peers (into {} (for [s squares]
[s (-> (reduce into #{} (units s)) (disj s))])))
(declare reduce-true assign eliminate)
;;; Unit Tests ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn unit-tests
"A set of tests that must pass"
;; NB: Tests normally go in separate files and and use clojure.test
[]
(assert (= 81 (count squares)))
(assert (= 27 (count unitlist)))
(assert (every? #(= 3 (count (units %))) squares))
(assert (every? #(= 20 (count (peers %))) squares))
(assert (= (units [:c 2])
[[[:a 2] [:b 2] [:c 2] [:d 2] [:e 2] [:f 2] [:g 2] [:h 2] [:i 2]]
[[:c 1] [:c 2] [:c 3] [:c 4] [:c 5] [:c 6] [:c 7] [:c 8] [:c 9]]
[[:a 1] [:a 2] [:a 3] [:b 1] [:b 2] [:b 3] [:c 1] [:c 2] [:c 3]]]))
(assert (= (peers [:c 2])
#{[:a 2] [:b 2] [:d 2] [:e 2] [:f 2] [:g 2] [:h 2] [:i 2]
[:c 1] [:c 3] [:c 4] [:c 5] [:c 6] [:c 7] [:c 8] [:c 9]
[:a 1] [:a 3] [:b 1] [:b 3]}))
:passed)
;;; Parse a Grid ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn grid-values
"Convert grid into a map of {square: digit}, with nil for empties"
[grid]
(zipmap squares (for [c grid :when (or (Character/isDigit c) (= \. c))]
(when-not (#{\0 \.} c)
(Character/digit c 10)))))
(defn parse-grid
"Convert grid to a map of possible values, {square: digits}. Return false
on contradiction"
[grid]
(reduce-true
(fn [values [s d]] (assign values s d))
(into {} (for [s squares] [s digits])) ;to start, any square can be any digit
(remove (comp nil? val) (grid-values grid))))
;;; Constraint Propagation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn assign
"Whittle down the square at s to digit d by eliminating every digit
except d from the square, and doing constraint propogation. Returns
false if a contradiction results"
[values s d]
(reduce-true #(eliminate %1 s %2)
values
(disj (values s) d)))
(defn eliminate
"Eliminate digit d from square s and do any appropriate constraint
propogation"
[values s d]
(if-not ((values s) d)
values ;already eliminated
(when-not (= #{d} (values s)) ;can't remove last value
(let [values (update-in values [s] disj d)
values (if (= 1 (count (values s)))
;; Only one digit left, eliminate it from peers
(reduce-true #(eliminate %1 %2 (first (%1 s)))
values
(peers s))
values)]
(reduce-true
(fn [values u]
(let [dplaces (for [s u :when ((values s) d)] s)]
(when-not (zero? (count dplaces)) ;must be a place for this value
(if (= 1 (count dplaces))
;; Only one spot remaining for d in a unit -- assign it
(assign values (first dplaces) d)
values))))
values
(units s))))))
;;; Display as 2D Grid ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn display
"Display values as a 2D grid"
[values]
(let [width (inc (apply max (map (comp count values) squares)))
line (join \+ (repeat 3 (join (repeat (* 3 width) \-))))]
(doseq [r rows]
(println (join (for [c cols]
(format (str "%-" width "s%s")
(join (values [r c]))
(if (#{3 6} c) "|" "")))))
(when (#{:c :f} r) (println line)))))
;;; Search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn search
"Using depth-first search and propagation, try all possible values"
[values]
(when values
(let [scount (comp count values)] ;digits remaining
(if (every? #(= 1 (scount %)) squares)
values ;solved!
(let [s (apply min-key scount (filter #(< 1 (scount %)) squares))]
(some identity (for [d (values s)]
(search (assign values s d)))))))))
(defn solve [grid] (-> grid parse-grid search))
;;; Utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn- reduce-true
"Like reduce but short-circuits upon logical false"
[f val coll]
(when val
(loop [val val, coll coll]
(if (empty? coll)
val
(when-let [val* (f val (first coll))]
(recur val* (rest coll)))))))
(defn sum [xs] (reduce + xs))
(defn transpose [xs] (apply map vector xs))
(defn from-file
([file] (from-file file "\n"))
([file sep] (-> file slurp trim (.split sep))))
;;; System Test ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn solved?
"A puzzle is solved if each unit is a permutation of the digits 1 to 9"
[values]
(and values (every? #(= (sort digits) (sort (mapcat values %))) unitlist)))
(defmacro time*
"Evaluates expr and returns [value time-in-seconds]"
[expr]
`(let [start# (System/nanoTime)
ret# ~expr]
[ret# (/ (double (- (System/nanoTime) start#)) 1000000000.0)]))
(defn solve-all
"Attempt to solve a sequence of grids. Report a summary of results."
[grids name]
(let [[results times] (transpose (map #(-> % solve solved? time*) grids))
solved (count (filter true? results))
n (count grids)]
(when (< 1 n)
(println
(format
"Solved %d of %d %s puzzles (avg %.2f secs (%.0f Hz), max %.2f secs)."
solved n name (/ (sum times) n) (/ n (sum times)) (apply max times))))))
(defn random-puzzle
"Make a random puzzle with N or more assignments. Restart on contradictions."
([] (random-puzzle 17))
([n]
(let [done? (fn [values]
(let [ds (apply concat (filter #(= 1 (count %)) (vals values)))]
(and (<= n (count ds)) (<= 8 (count (distinct ds))))))
steps (reductions #(assign %1 %2 (-> %2 %1 seq rand-nth))
(into {} (for [s squares] [s digits]))
(shuffle squares))
values (first (filter #(or (not %) (done? %)) steps))]
(if (nil? values)
(recur n) ;contradiction - retry
(join (for [ds (map values squares)]
(if (next ds) \. (first ds))))))))
(def grid1 "003020600900305001001806400008102900700000008006708200002609500800203009005010300")
(def grid2 "4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......")
(def hard1 ".....6....59.....82....8....45........3........6..3.54...325..6..................")
(def data-dir "/Users/tin/src/clj/playground/")
;; Expected to be run at the REPL
(defn run []
(unit-tests)
(solve-all (from-file (str data-dir "easy50.txt") "========") "easy")
(solve-all (from-file (str data-dir "top95.txt")) "hard")
(solve-all (from-file (str data-dir "hardest.txt")) "hardest")
(solve-all (repeatedly 99 random-puzzle) "random"))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment