Permalink
Browse files

LOGIC-124: fix disjoint?* bug uncovered by Ryan Senior's test

case. Add additional disjoint tests.
  • Loading branch information...
1 parent 9eeebde commit ce323c9bb85e080211eddfb7203a34104c62dee3 @swannodette swannodette committed Mar 24, 2013
Showing with 58 additions and 49 deletions.
  1. +13 −12 src/main/clojure/clojure/core/logic/fd.clj
  2. +45 −37 src/test/clojure/clojure/core/logic/tests.clj
@@ -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)
@@ -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
@@ -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.