Permalink
Browse files

* src/main/clojure/clojure/core/logic.clj: distinctfd seems about 3X …

…faster than master. can solve a big sudoku in about ~90ms-100ms which was what I was hoping for.
  • Loading branch information...
1 parent cf92d03 commit e80750b0cf4811fc9e2c66744deecf6e9cbedcc6 David Nolen committed Jul 31, 2012
@@ -3338,55 +3338,52 @@
(let [ncs (update-proc (.cs a) (id proc) proc)]
(make-s (.s a) (.l a) ncs))))
-;; NOTE: this implementation attempts to optimize by sharing across all variables.
-;; however this not optimal since this is run when a particular var becomes a singleton.
-;; then we could just remove that single value from all the other domains instead of
-;; having to run set/difference and looping over all the vars
+(defn categorize [s]
+ (fn [ys ds ss]
+ (if ys
+ (let [y (first ys)
+ v (walk s y)]
+ (cond
+ (lvar? v) (recur (next ys) ds ss)
+ (singleton-dom? v) (recur (next ys) ds (conj ss v))
+ :else (recur (next ys) (conj ds y) ss)))
+ {:doms ds :singletons ss})))
(defn -distinctfdc
- ([y* n*] (-distinctfdc y* n* nil))
- ([y* n* id]
+ ([x y* n*] (-distinctfdc x y* n* nil))
+ ([x y* n* id]
(reify
clojure.lang.IFn
(invoke [this s]
- (loop [y* (seq y*) n* n* x* #{}]
- (if y*
- (let [y (first y*)
- yv (walk s y)]
- (if (singleton-dom? yv)
- (if (n* yv)
- nil
- (recur (next y*) (conj n* yv) x*))
- (recur (next y*) n* (conj x* y))))
- ((composeg
- (exclude-from-dom (sorted-set->domain n*) x* s)
- (update-procg (-distinctfdc x* n* id))) s))))
- INeedsStore
- (needs-store? [_] true)
+ (let [x (walk s x)
+ {:keys [doms singletons]} ((categorize s) (seq y*) [] #{})]
+ (when-not (or (n* x) (singletons x))
+ (loop [doms (seq doms) s s]
+ (if doms
+ (let [d (first doms)
+ s ((process-dom d (difference (walk s d) x)) s)]
+ (when s
+ (recur (next doms) s)))
+ s)))))
IWithConstraintId
(with-id [this id]
- (-distinctfdc y* n* id))
+ (-distinctfdc x y* n* id))
IConstraintId
(id [this] id)
IConstraintOp
(rator [_] `-distinctfd)
- (rands [_] [(seq y*) (seq n*)])
+ (rands [_] [x])
IRelevant
(relevant? [this s]
- (pos? (count y*)))
+ (not (singleton-dom? (walk s x))))
(relevant? [this x s]
- (if (y* x)
- true
- false))
+ (relevant? this s))
IRunnable
(runnable? [this s]
- (or (pos? (count n*))
- (some (fn [y]
- (not (lvar? (walk s y))))
- y*))))))
+ (singleton-dom? (walk s x))))))
-(defn -distinctfd [y* n*]
- (cgoal (fdc (-distinctfdc y* n*))))
+(defn -distinctfd [x y* n*]
+ (cgoal (fdc (-distinctfdc x y* n*))))
(defn list-sorted? [pred ls]
(if (empty? ls)
@@ -3407,7 +3404,14 @@
{x* true n* false} (group-by lvar? v*)
n* (sort < n*)]
(when (list-sorted? < n*)
- ((-distinctfd (into #{} x*) (apply sorted-set n*)) s))))
+ (let [x* (into #{} x*)
+ n* (into (sorted-set) n*)]
+ (loop [xs (seq x*) s s]
+ (if xs
+ (let [x (first xs)]
+ (when-let [s ((-distinctfd x (disj x* x) n*) s)]
+ (recur (next xs) s)))
+ s))))))
IConstraintOp
(rator [_] `distinctfd)
(rands [_] [v*])
@@ -461,6 +461,7 @@
(comment
;; ~1668ms
+ ;; ~1171ms
(dotimes [_ 10]
(time
(dotimes [_ 1e3]
@@ -499,6 +500,22 @@
h1 h2 h3 h4 h5 h6 h7 h8 h9
i1 i2 i3 i4 i5 i6 i7 i8 i9
(domain 1 2 3 4 5 6 7 8 9))
+ (== a5 2)
+ (== a7 9)
+ (== b5 6)
+ (== b6 3)
+ (== b9 8)
+ (== c1 3)
+ (== c6 8)
+ (== c7 1)
+ (== c8 4)
+ (== d5 4)
+ (== d7 8)
+ (== d9 7)
+ (== e2 8)
+ (== e3 4)
+ (== e6 6)
+ (== e7 3)
(let [row1 [a1 a2 a3 a4 a5 a6 a7 a8 a9]
row2 [b1 b2 b3 b4 b5 b6 b7 b8 b9]
row3 [c1 c2 c3 c4 c5 c6 c7 c8 c9]
@@ -531,28 +548,12 @@
sq1 sq2 sq3 sq4 sq5 sq6 sq7 sq8 sq9])))))
(comment
- ;; 2.2s w/ interval
+ ;; ~946ms, about >3X faster than prior to optimize-distinctfd
+ ;; ~90ms to solve
(dotimes [_ 5]
- (time (big-sudokufd)))
- ;; ~1.4s w/ domain
-
- ;; this is 1000X slower than the small sudoku
+ (time
+ (dotimes [_ 10]
+ (big-sudokufd))))
(big-sudokufd)
-
- ;; 27869 calls to run-constraint
- ;; 13181 calls to run-constraints? because something is no longer refinable
- ;; 27875 calls to distinctfd
- ;; 137249 calls to process-dom
- ;; 141053 calls to FD difference
- ;; 6002 calls to -force-ans
- ;; yet only 26 constraints in the store
- ;; max running constraints - #{4 5 14 16 23}
-
- ;; these numbers seem high
-
- ;; not simple to make faster ops that sorted-set
- ;; can we eliminate the # of calls
-
- ;;
)
@@ -2036,12 +2036,13 @@
(deftest test-with-id
(let [x (lvar 'x)
+ y (lvar 'y)
n* (sorted-set 1 3 5)
- c (with-id (fdc (-distinctfdc #{x} (conj n* 7))) 1)]
+ c (with-id (fdc (-distinctfdc x #{y} (conj n* 7))) 1)]
(is (= (id c) 1))
(is (= (id (proc c)) 1))))
-(deftest test-update-procg
+#_(deftest test-update-procg
(let [x (lvar 'x)
y (lvar 'y)
n* (sorted-set 1 3 5)

0 comments on commit e80750b

Please sign in to comment.