From 06e6d2c1591799e2bc9d355ae5389407e74f7a8c Mon Sep 17 00:00:00 2001 From: Nada Amin Date: Wed, 19 Dec 2012 16:13:41 +0100 Subject: [PATCH] LOGIC-81: Resolve var keys for constraints using substitution map. --- src/main/clojure/clojure/core/logic.clj | 58 ++++++++++++------------- src/test/clojure/clojure/core/logic/tests.clj | 58 +++++++++++++++++++------ 2 files changed, 73 insertions(+), 43 deletions(-) diff --git a/src/main/clojure/clojure/core/logic.clj b/src/main/clojure/clojure/core/logic.clj index 363a7ba..489430c 100644 --- a/src/main/clojure/clojure/core/logic.clj +++ b/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 ""))) -(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)))))) diff --git a/src/test/clojure/clojure/core/logic/tests.clj b/src/test/clojure/clojure/core/logic/tests.clj index 12de38d..711648e 100644 --- a/src/test/clojure/clojure/core/logic/tests.clj +++ b/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 -- 1.7.10.4