clojure : alex's puzzle solver

puzzle.clj

(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))))