Skip to content

Instantly share code, notes, and snippets.

@mccraigmccraig
Created October 18, 2009 13:10
Show Gist options
  • Save mccraigmccraig/212674 to your computer and use it in GitHub Desktop.
Save mccraigmccraig/212674 to your computer and use it in GitHub Desktop.
clojure : alex's puzzle solver
(ns puzzle)
(defstruct board :size :values :value-index :constraints)
(defn create-board
"create a board with given size and constraints"
[size constraints]
(assert (> size 0))
(let [values (vec (range 1 (inc size)))
value-index (reduce (fn [h i] (assoc h (values i) i)) {} (range 0 (count values)))
the-board (struct-map board :size size :values values :value-index value-index)
board-constraints (constraints the-board)]
(assoc the-board :constraints board-constraints)))
(defn values-after
"values after n in sequence"
[board n]
(let [values (:values board)
value-index (:value-index board)]
(assert (contains? value-index n))
(subvec values (inc (value-index n)))))
(defn first-cell-last-cell-constraints
"constrain value of cell [n+1,0] = [n,SIZE-1]
i.e. first cell on new row is equal to last cell on first row"
[board]
(let [size (:size board)
cells (* size size)]
{:create-constraint
(fn [constraints-state solution]
(let [i (count solution)
row-len (mod i size)]
(fn [p] (and
(or (== 0 i)
(not (== i (dec cells))) ; last cell on board must equal first
(= p (nth solution 0)))
(or (== 0 i) ; first cell on row equals last on previous row
(not (== 0 row-len))
(= p (peek solution)))))))}))
(defn once-per-row-constraints
"each value can be used only once per row"
[board]
(let [size (:size board)]
{:create-constraint
(fn [constraints-state solution]
(let [i (count solution)
row (quot (count solution) size)
row-valset ((:row-valsets constraints-state) row)]
(fn [p]
(not (row-valset p)))))
:create-state
(fn [] {:row-valsets (reduce #(assoc % %2 #{}) {} (range 0 (:size board)))})
:push
(fn [constraints-state solution p]
(let [row (quot (count solution) size)
row-valsets (:row-valsets constraints-state)
row-valset (row-valsets row)
new-row-valset (conj row-valset p)
new-row-valsets (assoc row-valsets row new-row-valset)]
(assoc constraints-state :row-valsets new-row-valsets)))
:pop
(fn [constraints-state solution]
(let [p (peek solution)
row (quot (dec (count solution)) size)
row-valsets (:row-valsets constraints-state)
row-valset (row-valsets row)
new-row-valset (disj row-valset p)
new-row-valsets (assoc row-valsets row new-row-valset)]
(assoc constraints-state :row-valsets new-row-valsets)))}))
(defn once-per-column-constraints
"each value can be used only once per column"
[board]
(let [size (:size board)]
{:create-constraint
(fn [constraints-state solution]
(let [i (count solution)
col (mod (count solution) size)
col-valset ((:col-valsets constraints-state) col)]
(fn [p] (not (col-valset p)))))
:create-state
(fn [] {:col-valsets (reduce #(assoc % %2 #{}) {} (range 0 (:size board)))})
:push
(fn [constraints-state solution p]
(let [col (mod (count solution) size)
col-valsets (:col-valsets constraints-state)
col-valset (col-valsets col)
new-col-valset (conj col-valset p)
new-col-valsets (assoc col-valsets col new-col-valset)]
(assoc constraints-state :col-valsets new-col-valsets)))
:pop
(fn [constraints-state solution]
(let [p (peek solution)
col (mod (dec (count solution)) size)
col-valsets (:col-valsets constraints-state)
col-valset (col-valsets col)
new-col-valset (disj col-valset p)
new-col-valsets (assoc col-valsets col new-col-valset)]
(assoc constraints-state :col-valsets new-col-valsets)))}))
(defn each-transition-once-constraints
"each transition can be used only once"
[board]
{:create-constraint
(fn [constraints-state solution]
(let [transitions (:transitions constraints-state)
i (count solution)
n (peek solution)]
(fn [p] (or (== i 0)
(not (transitions [n p]))))))
:create-state
(fn [] {:transitions #{}})
:push
(fn [constraints-state solution p]
(let [transitions (:transitions constraints-state)
i (count solution)
n (peek solution)]
(if (> i 0) ; only push if there are transitions
(assoc constraints-state :transitions (conj transitions [n p]))
constraints-state)))
:pop
(fn [constraints-state solution]
(let [transitions (:transitions constraints-state)
i (count solution)]
(if (> i 1) ; only pop if there is a transition
(let [n (nth solution (- i 2))
p (peek solution)]
(assoc constraints-state :transitions (disj transitions [n p])))
constraints-state)))})
(defn combine-constraints
"combine multiple constraints"
[& constraints]
(fn [board]
(let [board-constraints (map #(% board) constraints)]
{ :create-constraint
(fn [constraints-state solution]
(let [constraints-fns (map #((:create-constraint %) constraints-state solution) board-constraints)]
(fn [p]
(reduce #(and % (%2 p)) true constraints-fns))))
:create-state
(fn []
(let [create-fns (map #(:create-state %) board-constraints)
states (map #(if % (%)) create-fns)]
(apply merge-with
(fn [& keys] (throw (RuntimeException. (print "key collision: " keys))))
states)))
:push
(fn [constraints-state solution p]
(let [push-fns (map #(:push %) board-constraints)]
(reduce #(if %2 (%2 % solution p) %) constraints-state push-fns)))
:pop
(fn [constraints-state solution]
(let [pop-fns (map #(:pop %) board-constraints)]
(reduce #(if %2 (%2 % solution) %) constraints-state pop-fns)))})))
(defn pop-push-constraints-state
"update constraint state by poppiing from solution then pushing p"
[constraints constraints-state solution p]
((:push constraints) ((:pop constraints) constraints-state solution) (pop solution) p))
; a search state
(defstruct search-state :board :constraints-state :solution)
(defn create-search-state
"create a search state, with optional constraints"
([board]
(let [constraints (:constraints board)]
(struct-map search-state
:board board
:constraints-state ((:create-state constraints))
:solution []))))
(defn valid-after
"sequence of values which are available and satisfy the constraint for a cell.
nil if there are no more transitions"
([board constraint p]
(let [all-values (:values board)
vals (if p (values-after board p) all-values)]
(filter #(or (not constraint) (constraint %))
vals))))
(defn next-valid
"next valid value, satisfying constraint"
([board constraint p]
(first (valid-after board constraint p))))
(defn next-solution-state
"depth first searcher, takes a state, returns the next solution"
[state]
(loop [constraints-state (:constraints-state state)
solution (:solution state)]
(let [board (:board state)
size (:size board)
cells (* size size)
i (count solution)
constraints (:constraints board)
constraint (if (> i 0) ((:create-constraint constraints) constraints-state (pop solution)) nil)]
; (print "try: " solution "\n")
(cond
(== i 0) ; open the first cell
(recur constraints-state (conj solution nil))
(<= i cells)
(let [p (peek solution)
next-p (next-valid board constraint p)]
; (print "p: " p "\nnext-p: " next-p "\nconstraints-state: " constraints-state "\nsolution: " solution "\n\n")
(if next-p ; update last cell, then open the next
(recur (pop-push-constraints-state constraints constraints-state solution next-p)
(conj (pop solution) next-p nil))
(if (> i 1)
(recur ((:pop constraints) constraints-state solution)
(pop solution)) ; unwind
nil))) ; the end
(> i cells) ; success
(let [new-solution (pop solution)]
; (print "**solution: " solution "\n\n")
(assoc state :constraints-state constraints-state :solution new-solution))))))
(defn solution-states
"a lazy sequence of solution search-states"
[state]
(lazy-seq
(let [solution (next-solution-state state)]
(if solution (cons solution (solution-states solution))))))
(defn solutions
"a lazy sequence of solutions"
[solution-states]
(map #(:solution %) solution-states))
(defn print-solutions
"print a seq of solutions"
[solutions]
(dorun (map #(print % "\n") solutions)))
; a combination of constraints including once-per-column
(def row-constraints
(combine-constraints each-transition-once-constraints
once-per-row-constraints
first-cell-last-cell-constraints))
; a combination of constraints including once-per-column and once-per-row
(def row-column-constraints
(combine-constraints each-transition-once-constraints
once-per-row-constraints
once-per-column-constraints
first-cell-last-cell-constraints))
(defn solve
"solve for a board size with given constraints e.g.
(solve 6 row-constraints)
(solve 8 row-column-constraints)"
[size constraints]
(let [board (create-board size constraints)
initial-state (create-search-state board)]
(solutions (solution-states initial-state))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment