clojure : early version of alex's puzzle solver

gistfile1.clj

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