Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

LOGIC-81: Resolve var keys for constraints using substitution map.

  • Loading branch information...
commit 0f7de6ed7125df65f4450d5507341a98b151001a 1 parent 7db01c7
@namin namin authored David Nolen committed
View
58 src/main/clojure/clojure/core/logic.clj
@@ -151,11 +151,11 @@
;; Constraint Store
(defprotocol IConstraintStore
- (addc [this c])
- (updatec [this c])
- (remc [this c])
+ (addc [this a c])
+ (updatec [this a c])
+ (remc [this a c])
(runc [this c state])
- (constraints-for [this x ws])
+ (constraints-for [this a x ws])
(migrate [this u v]))
;; -----------------------------------------------------------------------------
@@ -814,12 +814,16 @@
(defmethod print-method MultiIntervalFD [x ^Writer writer]
(.write writer (str "<intervals:" (apply pr-str (:is x)) ">")))
-(defn var-rands [c]
+(defn var-rands [a c]
(->> (rands c)
- flatten
+ (map #(root-var a %))
(filter lvar?)
(into [])))
+(defn unbound-rands [a c]
+ (->> (var-rands a c)
+ (filter #(lvar? (root-val a %)))))
+
(declare add-var)
;; ConstraintStore
@@ -842,23 +846,23 @@
:running running
not-found))
IConstraintStore
- (addc [this c]
- (let [vars (var-rands c)
+ (addc [this a c]
+ (let [vars (var-rands a c)
c (with-id c cid)
cs (reduce (fn [cs v] (add-var cs v c)) this vars)]
(ConstraintStore. (:km cs) (:cm cs) (inc cid) running)))
- (updatec [this c]
+ (updatec [this a c]
(let [oc (cm (id c))
nkm (if (instance? clojure.core.logic.IRelevantVar c)
(reduce (fn [km x]
(if-not (-relevant-var? c x)
(dissoc km x)
km))
- km (var-rands oc))
+ km (var-rands a oc))
km)]
(ConstraintStore. nkm (assoc cm (id c) c) cid running)))
- (remc [this c]
- (let [vs (var-rands c)
+ (remc [this a c]
+ (let [vs (var-rands a c)
ocid (id c)
nkm (reduce (fn [km v]
(let [vcs (disj (get km v) ocid)]
@@ -872,8 +876,8 @@
(if state
(ConstraintStore. km cm cid (conj running (id c)))
(ConstraintStore. km cm cid (disj running (id c)))))
- (constraints-for [this x ws]
- (when-let [ids (get km x)]
+ (constraints-for [this a x ws]
+ (when-let [ids (get km (root-var a x))]
(filter #((watched-stores %) ws) (map cm (remove running ids)))))
(migrate [this u v]
(let [ucs (km u)
@@ -1167,11 +1171,6 @@
l (reduce (fn [l [k v]] (cons (Pair. k v) l)) '() v)]
(make-s s l (make-cs))))
-(defn unbound-rands [a c]
- (->> (rands c)
- flatten
- (filter #(lvar? (root-val a %)))))
-
(defn annotate [k v]
(fn [a]
(vary-meta a assoc k v)))
@@ -2859,15 +2858,15 @@
(let [a (reduce (fn [a x]
(ext-no-check a x (subst-val ::unbound)))
a (unbound-rands a c))]
- (assoc a :cs (addc (:cs a) c)))))
+ (assoc a :cs (addc (:cs a) a c)))))
(defn updatecg [c]
(fn [a]
- (assoc a :cs (updatec (:cs a) c))))
+ (assoc a :cs (updatec (:cs a) a c))))
(defn remcg [c]
(fn [a]
- (assoc a :cs (remc (:cs a) c))))
+ (assoc a :cs (remc (:cs a) a c))))
(defn runcg [c]
(fn [a]
@@ -2930,12 +2929,13 @@
(if (or (zero? (count cs))
(nil? (seq xs)))
s#
- (let [xcs (constraints-for cs (first xs) ws)]
- (if (seq xcs)
- (composeg
- (run-constraints xcs)
- (run-constraints* (next xs) cs ws))
- (run-constraints* (next xs) cs ws)))))
+ (fn [a]
+ (let [xcs (constraints-for cs a (first xs) ws)]
+ (if (seq xcs)
+ (bind* a
+ (run-constraints xcs)
+ (run-constraints* (next xs) cs ws))
+ (bind a (run-constraints* (next xs) cs ws)))))))
(declare get-dom)
@@ -3796,7 +3796,7 @@
pp (prefix oc)]
(cond
(prefix-subsumes? pp p) ((remcg c) a)
- (prefix-subsumes? p pp) (recur (assoc a :cs (remc cs oc)) (next neqcs))
+ (prefix-subsumes? p pp) (recur (assoc a :cs (remc cs a oc)) (next neqcs))
:else (recur a (next neqcs))))
((updatecg c) a))))))
View
58 src/test/clojure/clojure/core/logic/tests.clj
@@ -1681,7 +1681,7 @@
(let [u (lvar 'u)
w (lvar 'w)
c (fdc (=fdc u w))]
- (is (= (var-rands c)
+ (is (= (var-rands empty-s c)
[u w]))
(is (= (rator c)
`=fd))
@@ -1693,7 +1693,7 @@
v 1
w (lvar 'w)
c (+fdc u v w)]
- (is (= (var-rands c)
+ (is (= (var-rands empty-s c)
[u w]))
(is (= (rator c)
`+fd))
@@ -1705,7 +1705,7 @@
v 1
w (lvar 'w)
c (fdc (+fdc u v w))]
- (is (= (var-rands c)
+ (is (= (var-rands empty-s c)
[u w]))
(is (= (rator c)
`+fd))
@@ -1717,8 +1717,8 @@
v 1
w (lvar 'w)
c (fdc (+fdc u v w))
- cs (addc (make-cs) c)
- sc (first (constraints-for cs u ::l/fd))]
+ cs (addc (make-cs) empty-s c)
+ sc (first (constraints-for cs empty-s u ::l/fd))]
(is (= c sc))
(is (= (id sc) 0))
(is (= (count (:km cs)) 2))
@@ -1731,9 +1731,9 @@
c0 (fdc (+fdc u v w))
x (lvar 'x)
c1 (fdc (+fdc w v x))
- cs (-> (make-cs )
- (addc c0)
- (addc c1))
+ cs (-> (make-cs)
+ (addc empty-s c0)
+ (addc empty-s c1))
sc0 (get (:cm cs) 0)
sc1 (get (:cm cs) 1)]
(is (= sc0 c0)) (is (= (id sc0) 0))
@@ -1757,7 +1757,7 @@
w (lvar 'w)
c (fdc (+fdc u v w))
s ((addcg c) empty-s)
- c (first (constraints-for (:cs s) u ::fd))
+ c (first (constraints-for (:cs s) s u ::fd))
s (-> s
(ext-no-check u 1)
(ext-no-check w 2))
@@ -2171,9 +2171,9 @@
y (lvar 'y)
z (lvar 'z)
c (fdc (+fdc x y z))
- cs (addc (make-cs) c)
+ cs (addc (make-cs) empty-s c)
cp (get (:cm cs) 0)
- cs (remc cs cp)]
+ cs (remc cs empty-s cp)]
(is (= (:km cs) {}))
(is (= (:cm cs) {}))))
@@ -2187,7 +2187,7 @@
(let [x (lvar 'x)
y (lvar 'y)
c (!=c (list (pair x 1) (pair y 2)))
- cs (addc (make-cs) c)]
+ cs (addc (make-cs) empty-s c)]
(is (tree-constraint? ((:cm cs) 0)))
(is (= (into #{} (keys (:km cs)))
#{x y}))))
@@ -2255,7 +2255,7 @@
y (lvar 'y)
c (!=c (list (pair x 1)))
sc (!=c (list (pair x 1) (pair y 2)))
- cs (addc (make-cs) c)]
+ cs (addc (make-cs) empty-s c)]
))
(deftest test-multi-constraints-1 []
@@ -2364,6 +2364,24 @@
s (unify empty-s x0 x1)]
(is (= s empty-s))))
+(deftest test-logic-81-fd []
+ (is (= (run* [q]
+ (fresh [x y]
+ (== q x)
+ (distinctfd [q y])
+ (== y x)
+ (infd q x y (interval 1 3))))
+ ()))
+ (is (= (run* [q]
+ (fresh [x y z]
+ (== q x)
+ (== y z)
+ (distinctfd [q y])
+ (distinctfd [q x])
+ (== z q)
+ (infd q x y z (interval 1 3))))
+ ())))
+
;; =============================================================================
;; predc
@@ -2386,7 +2404,19 @@
(is (= (run* [q]
(== q "foo")
(predc q number? `number?))
- ())))
+ ()))
+ (is (= (run* [q]
+ (fresh [x]
+ (predc q number? `number?)
+ (== q x)
+ (== x "foo")))
+ ()))
+ (is (= (run* [q]
+ (fresh [x]
+ (== q x)
+ (predc q number? `number?)
+ (== x "foo")))
+ ())))
;; =============================================================================
;; Real cKanren programs
Please sign in to comment.
Something went wrong with that request. Please try again.