Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
LOGIC-124: fix disjoint?* bug uncovered by Ryan Senior's test
case. Add additional disjoint tests.
  • Loading branch information
swannodette committed Mar 24, 2013
1 parent 9eeebde commit ce323c9
Show file tree
Hide file tree
Showing 2 changed files with 58 additions and 49 deletions.
25 changes: 13 additions & 12 deletions src/main/clojure/clojure/core/logic/fd.clj
Expand Up @@ -466,18 +466,19 @@
(defn disjoint?* [is js]
(if (disjoint? (interval (lb is) (ub is))
(interval (lb js) (ub js)))
true
(let [d0 (intervals is)
d1 (intervals js)]
(loop [d0 d0 d1 d1]
(if (nil? d0)
true
(let [i (first d0)
j (first d1)]
(cond
(or (interval-< i j) (disjoint? i j)) (recur (next d0) d1)
(interval-> i j) (recur d0 (next d1))
:else false)))))))
true
(let [d0 (intervals is)
d1 (intervals js)]
(loop [d0 d0 d1 d1]
(if (or (nil? d0) (nil? d1))
true
(let [i (first d0)
j (first d1)]
(cond
(interval-< i j) (recur (next d0) d1)
(interval-> i j) (recur d0 (next d1))
(disjoint? i j) (recur (next d0) d1)
:else false)))))))

(declare normalize-intervals singleton-dom? multi-interval)

Expand Down
82 changes: 45 additions & 37 deletions src/test/clojure/clojure/core/logic/tests.clj
Expand Up @@ -1750,6 +1750,51 @@
(== x {:foo {:baz 1}}))
'())))

(deftest test-disjoint-logic-124
(is (false? (fd/disjoint?
(fd/interval 2 4)
(fd/multi-interval 1 (fd/interval 3 4)))))
(is (false? (fd/disjoint?
(fd/multi-interval 1 (fd/interval 3 4))
(fd/interval 2 4)))))

(deftest test-arch-friends-problem
(let [expected [{:wedges 2,
:flats 4,
:pumps 1,
:sandals 3,
:foot-farm 2,
:heels-in-a-hand-cart 4,
:shoe-palace 1,
:tootsies 3}]]
(is (= expected
(run* [q]
(fresh [wedges flats pumps sandals
ff hh sp tt pumps+1]
(fd/in wedges flats pumps sandals
ff hh sp tt pumps+1 (fd/interval 1 4))
(fd/distinct [wedges flats pumps sandals])
(fd/distinct [ff hh sp tt])
(fd/== flats hh)
(fd/+ pumps 1 pumps+1)

;;Flipping the order of pumps+1 and tt causes this
;;test to pass. Moving the fd/!= call after the
;;(fd/== ff 2) or (fd/+ sp 2 sandals) call also
;;causes it to pass (fd/!= argument order doesn't matter)
(fd/!= pumps+1 tt)

(fd/== ff 2)
(fd/+ sp 2 sandals)
(== q {:wedges wedges
:flats flats
:pumps pumps
:sandals sandals
:foot-farm ff
:heels-in-a-hand-cart hh
:shoe-palace sp
:tootsies tt})))))))

;; =============================================================================
;; cKanren

Expand Down Expand Up @@ -3318,40 +3363,3 @@
(let [x (lvar 'x)
s (update-dom empty-s x ::nom (fnil (fn [d] (conj d '(swap x y))) []))]
(is (= (get-dom s x ::nom) '[(swap x y)]))))

(deftest test-arch-friends-problem
(let [expected [{:wedges 2,
:flats 4,
:pumps 1,
:sandals 3,
:foot-farm 2,
:heels-in-a-hand-cart 4,
:shoe-palace 1,
:tootsies 3}]]
(is (= expected
(run* [q]
(fresh [wedges flats pumps sandals
ff hh sp tt pumps+1]
(fd/in wedges flats pumps sandals
ff hh sp tt pumps+1 (fd/interval 1 4))
(fd/distinct [wedges flats pumps sandals])
(fd/distinct [ff hh sp tt])
(fd/== flats hh)
(fd/+ pumps 1 pumps+1)

;;Flipping the order of pumps+1 and tt causes this
;;test to pass. Moving the fd/!= call after the
;;(fd/== ff 2) or (fd/+ sp 2 sandals) call also
;;causes it to pass (fd/!= argument order doesn't matter)
(fd/!= pumps+1 tt)

(fd/== ff 2)
(fd/+ sp 2 sandals)
(== q {:wedges wedges
:flats flats
:pumps pumps
:sandals sandals
:foot-farm ff
:heels-in-a-hand-cart hh
:shoe-palace sp
:tootsies tt})))))))

0 comments on commit ce323c9

Please sign in to comment.