Skip to content

Instantly share code, notes, and snippets.

@mccraigmccraig
Created October 18, 2009 00:16
Show Gist options
  • Save mccraigmccraig/212493 to your computer and use it in GitHub Desktop.
Save mccraigmccraig/212493 to your computer and use it in GitHub Desktop.
clojure : early version of alex's puzzle solver
(defstruct board :size :values :value-index :all-transitions)
(defn create-board
"create a board of a given size"
[size]
(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)))
all-transitions (reduce (fn [t n] (assoc t n (set values))) {} values)]
(struct-map board
:size size
:values values
:value-index value-index
:all-transitions all-transitions)))
(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 use-transition
"remove transition from n to p"
[t n p]
(assert (contains? t n))
(let [nt (t n)]
(assert (contains? nt p))
(assoc t n (disj nt p))))
(defn unuse-transition
"insert transition from value n to value p"
[t n p]
(assert (contains? t n))
(if p
(let [nt (t n)]
(assert (not (contains? nt p)))
(assoc t n (conj nt p)))
t))
(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 solution]
(let [size (:size board)
i (count solution)
row-len (mod i size)]
(fn [p] (or (== 0 i)
(not (== 0 row-len))
(= p (peek solution))))))
(defn once-per-row-constraints
"each value can only appear once per row"
[board solution]
(let [size (:size board)
i (count solution)
row-vals (set (subvec solution (- i (mod i size))))]
(fn [p] (not (contains? row-vals p)))))
(defn once-per-column-constraints
"each value can only appear once per column"
[board solution]
(let [size (:size board)
i (count solution)
col-vals (set (take-nth size (drop (mod i size) solution)))]
(fn [p] (not (contains? col-vals p)))))
(defn combine-constraints
"combine multiple constraints"
[& constraints]
(fn [board solution]
(let [constraint-fns (map #(% board solution) constraints)]
(fn [p]
(reduce #(and % (%2 p)) true constraint-fns)))))
; once-per-row and first-cell-of-new-row = last-cell-of-prev-row
(def row-constraints
(combine-constraints once-per-row-constraints first-cell-last-cell-constraints))
; once-per-row, once-per-column and first-cell-of-new-row=last-cell-of-prev-row
(def row-column-constraints
(combine-constraints once-per-row-constraints once-per-column-constraints first-cell-last-cell-constraints))
; a search state
(defstruct search-state :board :constraints :transitions :solution)
(defn create-search-state
"create a search state, with optional constraints"
([board]
(create-search-state board (combine-constraints
once-per-row-constraints
once-per-column-constraints
first-cell-last-cell-constraints)))
([board constraints]
(struct-map search-state
:board board
:constraints constraints
:transitions (:all-transitions board)
: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 n] ; initialise - apply constraint, without any transition
(let [all-values (:values board)
vals (if n (values-after board n) all-values)]
(filter #(or (not constraint) (constraint %)) vals)))
([board constraint t n p] ; apply constraint and require available transition
(let [tn (t n)
all-values (:values board)
vals (if p (values-after board p) all-values)]
(filter #(and (contains? tn %)
(or (not constraint) (constraint %)))
vals))))
(defn next-valid
"next valid value, satisfying constraint and with available transition"
([board constraint n]
(first (valid-after board constraint n)))
([board constraint t n p]
(first (valid-after board constraint t n p))))
(defn next-solution-state
"depth first searcher, takes a state, returns the next solution"
[state]
(loop [transitions (:transitions state)
solution (:solution state)]
(let [board (:board state)
size (:size board)
cells (* size size)
i (count solution)
constraint (if (> i 0) ((:constraints state) board (pop solution)) nil)]
; (print "solution: " solution "\n")
(cond
(== i 0) ; open the first cell
(recur transitions (conj solution nil))
(== i 1)
(let [p (nth solution 0)
next-p (next-valid board constraint p)]
; (print "p: " p ", next-p: " next-p ", t: " transitions "\n")
(if next-p ; update last cell, then open the next
(recur transitions (conj (pop solution) next-p nil))
nil)) ; the end
(<= i cells) ; change the last cell, then open the next cell
(let [n (nth solution (- i 2))
p (nth solution (dec i))
next-p (next-valid board constraint transitions n p)]
; (print "n: " n ", p: " p ", next-p: " next-p ", t: " transitions "\n")
(if next-p ; update last cell, then open the next
(recur (use-transition (unuse-transition transitions n p) n next-p) (conj (pop solution) next-p nil))
(recur (unuse-transition transitions n p) (pop solution)))) ;; else unwind
(> i cells) ; if valid then return else unwind
(let [n (nth solution (dec cells))
p (first solution)]
; (print "n: " n ", p: " p ", t: " transitions "\n")
(if ((transitions n) p) ; success... don't use the loop transition tho
(assoc state :transitions transitions :solution (subvec solution 0 cells))
(recur transitions 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)))
(defn solve
"solve for a board size with given constraints"
[size constraints]
(let [board (create-board size)
initial-state (create-search-state board constraints)]
(solutions (solution-states initial-state))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment