Core.logic solutin for "Klondike" puzzle

klondike.clj

;; core.logic solution for "Klondike" puzzle:
;; http://www.futilitycloset.com/2014/01/27/back-from-the-klondike/

;; unfortunately, on the real problem it dies with OutOfMemoryError.
;; but theoretically it works :)

(ns klondike.core
  (:refer-clojure :exclude [== !=])
  (:require [clojure.core.logic    :refer [run == != fresh appendo conde all fail project]]
            [clojure.core.logic.fd :as fd]))


(def puzzle
  (let [_ -1
        | 0]

    [[_ _ _ _ _]
     [_ 8 8 8 _]
     [_ 2 1 8 _]
     [_ 8 8 8 _]
     [_ _ _ | _]]

    
    ;[[_ _ _ _ _ _ _ _ _ | | | | | _ _ _ _ _ _ _ _ _]
    ; [_ _ _ _ _ _ | | | | 4 7 7 | | | | _ _ _ _ _ _]
    ; [_ _ _ _ | | | 5 4 4 8 3 3 4 6 3 | | | _ _ _ _]
    ; [_ _ _ | | 1 4 5 1 1 1 4 5 1 7 1 3 5 | | _ _ _]
    ; [_ _ | | 4 9 4 9 6 7 5 5 5 8 7 6 6 8 5 | | _ _]
    ; [_ _ | 3 7 2 9 8 3 5 6 7 3 9 1 8 7 5 8 5 | _ _]
    ; [_ | | 1 4 7 8 4 2 9 2 7 1 1 8 2 2 7 6 3 | | _]
    ; [_ | 7 2 1 8 5 5 3 1 1 3 1 3 3 4 2 8 6 1 3 | _]
    ; [_ | 4 2 6 7 2 5 2 4 2 2 5 4 3 2 8 1 7 7 3 | _]
    ; [| | 4 1 6 5 1 1 1 9 1 4 3 4 4 3 1 9 8 2 7 | |]
    ; [| 4 3 5 2 3 2 2 3 2 4 2 5 3 5 1 1 3 5 5 3 7 |]
    ; [| 2 7 1 5 1 1 3 1 5 3 3 2 4 2 3 7 7 5 4 2 7 |]
    ; [| 2 5 2 2 6 1 2 4 4 6 3 4 1 2 1 2 6 5 1 8 8 |]
    ; [| | 4 3 7 5 1 9 3 4 4 5 2 9 4 1 9 5 7 4 8 | |]
    ; [_ | 4 1 6 7 8 3 4 3 4 1 3 1 2 3 2 3 6 2 4 | _]
    ; [_ | 7 3 2 6 1 5 3 9 2 3 2 1 5 7 5 8 9 5 4 | _]
    ; [_ | | 1 6 7 3 4 8 1 1 1 2 1 2 2 8 9 4 1 | | _]
    ; [_ _ | 2 5 4 7 8 7 5 6 1 3 5 7 8 7 2 9 3 | _ _]
    ; [_ _ | | 6 5 6 4 6 7 2 5 2 2 6 3 4 7 4 | | _ _]
    ; [_ _ _ | | 2 3 1 2 3 3 3 2 1 3 2 1 1 | | _ _ _]
    ; [_ _ _ _ | | | 7 4 4 5 7 3 4 4 7 | | | _ _ _ _]
    ; [_ _ _ _ _ _ | | | | 3 3 4 | | | | _ _ _ _ _ _]
    ; [_ _ _ _ _ _ _ _ _ | | | | | _ _ _ _ _ _ _ _ _]]


    ))

(defn only-one-zero [end-x end-y dir]
  ;; We allow only one zero - at the point [end-x end-y].
  ;; We must check the direction from which we came.
  (let [[before-x before-y] (map + [end-x end-y] (case dir
                                                   :n  [ 0  1]
                                                   :s  [ 0 -1]
                                                   :w  [ 1  0]
                                                   :e  [-1  0]
                                                   :ne [-1  1]
                                                   :nw [ 1  1]
                                                   :se [-1 -1]
                                                   :sw [ 1 -1]))]
    (not= 0 (get-in puzzle [before-y before-x] -1))))

(defn at [q x y dir]
  (all
   (fd/in x y (fd/interval 0 (dec (count puzzle))))
   (fresh [value]
     (project [x y] (== value (get-in puzzle [y x] -1)))
     (conde [(== value 0)
             (project [x y dir] (== true (only-one-zero x y dir)))
             (== q [[x y :done value]])]
            [(!= value -1)
             (!= value 0)
             (fresh [direction step old-q new-x new-y]
               (== step [[x y direction value]])
               (appendo step old-q q)
               (conde [(== direction :n)  (fd/eq (= new-x x)           (= new-y (- y value)))]
                      [(== direction :s)  (fd/eq (= new-x x)           (= new-y (+ y value)))]
                      [(== direction :w)  (fd/eq (= new-x (- x value)) (= new-y y))]
                      [(== direction :e)  (fd/eq (= new-x (+ x value)) (= new-y y))]
                      [(== direction :nw) (fd/eq (= new-x (- x value)) (= new-y (- y value)))]
                      [(== direction :sw) (fd/eq (= new-x (- x value)) (= new-y (+ y value)))]
                      [(== direction :ne) (fd/eq (= new-x (+ x value)) (= new-y (- y value)))]
                      [(== direction :se) (fd/eq (= new-x (+ x value)) (= new-y (+ y value)))])
               (at old-q new-x new-y direction))]))))

(defn d []
  (let [length (count puzzle)
        max-index (dec length)
        mid-index (quot length 2)]
    (run 1 [q]
      (fresh [x y]
        (fd/in x y (fd/interval 0 max-index))
        (fd/== x mid-index)
        (fd/== y mid-index)
        (at q x y :start)))))