Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge branch 'no-update'

  • Loading branch information...
commit d4d4cd53edfd76c2f416bd699f4b4d914f880985 2 parents 8faf77f + 6b5088a
@swannodette swannodette authored
View
162 src/main/clojure/clojure/core/logic.clj
@@ -132,7 +132,7 @@
(defprotocol ISubstitutionsCLP
(root-val [this x])
(root-var [this x])
- (update [this x v])
+ (ext-run-cs [this x v])
(queue [this c])
(update-var [this x v]))
@@ -145,7 +145,7 @@
(remc [this a c])
(runc [this c state])
(constraints-for [this a x ws])
- (migrate [this u v]))
+ (migrate [this x root]))
;; -----------------------------------------------------------------------------
;; Generic constraint protocols
@@ -883,10 +883,10 @@
(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)
- vcs (km v)
- nkm (assoc (dissoc km u) v (into vcs ucs))]
+ (migrate [this x root]
+ (let [xcs (km x)
+ rootcs (km root)
+ nkm (assoc (dissoc km x) root (into rootcs xcs))]
(ConstraintStore. nkm cm cid running)))
clojure.lang.Counted
(count [this]
@@ -952,8 +952,8 @@
(defn unify [s u v]
(if (identical? u v)
s
- (let [u (walk s u)
- v (walk s v)]
+ (let [u (walk s u)
+ v (walk s v)]
;; TODO: we can't use an identical? check here at the moment
;; because we add metadata on vars in walk - David
(if (and (lvar? u) (= u v))
@@ -988,12 +988,12 @@
;; Substitutions
;; -----
;; s - persistent hashmap to store logic var bindings
-;; l - persistent list of var bindings to support disequality constraints
+;; vs - changed var set
;; cs - constraint store
;; cq - for the constraint queue
;; cqs - constraint ids in the queue
-(deftype Substitutions [s l cs cq cqs _meta]
+(deftype Substitutions [s vs cs cq cqs _meta]
Object
(equals [this o]
(or (identical? this o)
@@ -1008,7 +1008,7 @@
clojure.lang.IObj
(meta [this] _meta)
(withMeta [this new-meta]
- (Substitutions. s l cs cq cqs new-meta))
+ (Substitutions. s vs cs cq cqs new-meta))
clojure.lang.ILookup
(valAt [this k]
@@ -1016,7 +1016,7 @@
(valAt [this k not-found]
(case k
:s s
- :l l
+ :vs vs
:cs cs
:cq cq
:cqs cqs
@@ -1033,34 +1033,30 @@
clojure.lang.Associative
(containsKey [this k]
- (contains? #{:s :l :cs :cq :cqs} k))
+ (contains? #{:s :vs :cs :cq :cqs} k))
(entryAt [this k]
(case k
:s [:s s]
- :l [:l l]
+ :vs [:vs vs]
:cs [:cs cs]
:cq [:cq cq]
:cqs [:cqs cqs]
nil))
(assoc [this k v]
(case k
- :s (Substitutions. v l cs cq cqs _meta)
- :l (Substitutions. s v cs cq cqs _meta)
- :cs (Substitutions. s l v cq cqs _meta)
- :cq (Substitutions. s l cs v cqs _meta)
- :cqs (Substitutions. s l cs cq v _meta)
+ :s (Substitutions. v vs cs cq cqs _meta)
+ :vs (Substitutions. s v cs cq cqs _meta)
+ :cs (Substitutions. s vs v cq cqs _meta)
+ :cq (Substitutions. s vs cs v cqs _meta)
+ :cqs (Substitutions. s vs cs cq v _meta)
(throw (Exception. (str "Substitutions has no field for key" k)))))
ISubstitutions
(ext-no-check [this u v]
(let [u (if-not (lvar? v)
(assoc-meta u ::root true)
- u)
- l (if (and (subst-val? v)
- (= (:v v) ::unbound))
- l
- (cons (pair u v) l))]
- (Substitutions. (assoc s u v) l cs cq cqs _meta)))
+ u)]
+ (Substitutions. (assoc s u v) (if vs (conj vs u)) cs cq cqs _meta)))
(walk [this v]
(if (lvar? v)
@@ -1104,22 +1100,16 @@
:else (recur vp (find s vp)))))
v))
- (update [this x v]
- (let [xv (root-val this x)
- sval? (subst-val? xv)]
- (if (or (lvar? xv) (and sval? (= (:v xv) ::unbound)))
- (let [x (root-var this x)
- xs (if (lvar? v)
- [x (root-var this v)]
- [x])
- v (if sval? (assoc xv :v v) v)
- s (if *occurs-check*
- (ext this x v)
- (ext-no-check this x v))]
- (when s
- ((run-constraints* xs cs ::subst) s)))
- (when (= (if sval? (:v xv) v) v) ;; NOTE: replace with unify?
- this))))
+ (ext-run-cs [this x v]
+ (let [x (root-var this x)
+ xs (if (lvar? v)
+ [x (root-var this v)]
+ [x])
+ s (if *occurs-check*
+ (ext this x v)
+ (ext-no-check this x v))]
+ (when s
+ ((run-constraints* xs cs ::subst) s))))
(queue [this c]
(let [id (id c)]
@@ -1188,10 +1178,9 @@
(-> v :doms dom))))
(defn- make-s
- ([] (Substitutions. {} () (make-cs) nil #{} nil))
- ([m] (Substitutions. m () (make-cs) nil #{} nil))
- ([m l] (Substitutions. m l (make-cs) nil #{} nil))
- ([m l cs] (Substitutions. m l cs nil #{} nil)))
+ ([] (Substitutions. {} nil (make-cs) nil #{} nil))
+ ([m] (Substitutions. m nil (make-cs) nil #{} nil))
+ ([m cs] (Substitutions. m nil cs nil #{} nil)))
(def empty-s (make-s))
(def empty-f (fn []))
@@ -1200,14 +1189,19 @@
(instance? Substitutions x))
(defn to-s [v]
- (let [s (reduce (fn [m [k v]] (assoc m k v)) {} v)
- l (reduce (fn [l [k v]] (cons (Pair. k v) l)) '() v)]
- (make-s s l (make-cs))))
+ (let [s (reduce (fn [m [k v]] (assoc m k v)) {} v)]
+ (make-s s (make-cs))))
(defn annotate [k v]
(fn [a]
(vary-meta a assoc k v)))
+(defn merge-subst-vals [x root]
+ (subst-val
+ (:v root)
+ (merge-with -merge-doms (:doms x) (:doms root))
+ (merge (meta x) (meta root))))
+
;; =============================================================================
;; Logic Variables
@@ -1236,12 +1230,21 @@
(unify-terms [u v s]
(cond
(lvar? v)
- (if (-> u clojure.core/meta ::unbound)
- (let [s (if (-> v clojure.core/meta ::unbound)
- (assoc s :cs (migrate (:cs s) v u))
- s)]
- (ext-no-check s v u))
- (ext-no-check s u v))
+ (let [repoint (cond
+ (-> u clojure.core/meta ::unbound) [u v]
+ (-> v clojure.core/meta ::unbound) [v u]
+ :else nil)]
+ (if repoint
+ (let [[root other] repoint
+ s (assoc s :cs (migrate (:cs s) other root))
+ s (if (-> other clojure.core/meta ::unbound)
+ (ext-no-check s root
+ (merge-subst-vals
+ (root-val s other)
+ (root-val s root)))
+ s)]
+ (ext-no-check s other root))
+ (ext-no-check s u v)))
(non-storable? v)
(throw (Exception. (str v " is non-storable")))
@@ -1249,7 +1252,9 @@
(not= v ::not-found)
(if (or (coll? v) (lcons? v))
(ext s u v)
- (ext-no-check s u v))
+ (if (-> u clojure.core/meta ::unbound)
+ (ext-no-check s u (assoc (root-val s u) :v v))
+ (ext-no-check s u v)))
:else nil))
IReifyTerm
@@ -1689,31 +1694,17 @@
(def u# fail)
-(defn updateg [u v]
+(defn ext-run-csg [u v]
(fn [a]
- (update a u v)))
-
-(defn update-prefix [a ap]
- (let [l (:l a)]
- ((fn loop [lp]
- (if (identical? l lp)
- s#
- (let [[lhs rhs] (first lp)]
- (composeg
- (updateg lhs rhs)
- (loop (rest lp)))))) (:l ap))))
-
-;; NOTE: this seems costly if the user introduces a constraint
-;; update-prefix should be called only if we have a constraint
-;; in the store that needs this
+ (ext-run-cs a u v)))
(defn ==
"A goal that attempts to unify terms u and v."
[u v]
(fn [a]
- (when-let [ap (unify a u v)]
+ (when-let [ap (unify (assoc a :vs #{}) u v)]
(if (pos? (count (:cs a)))
- ((update-prefix a ap) a)
+ ((run-constraints* (:vs ap) (:cs ap) ::subst) (assoc ap :vs nil))
ap))))
(defn- bind-conde-clause [a]
@@ -2838,8 +2829,7 @@
(defn ext-dom-fd
[a x dom]
- (let [x (root-var a x)
- domp (get-dom-fd a x)
+ (let [domp (get-dom-fd a x)
a (add-dom a x ::fd dom)]
(if (not= domp dom)
((run-constraints* [x] (:cs a) ::fd) a)
@@ -3023,7 +3013,7 @@
(defn resolve-storable-dom
[a x dom]
(if (singleton-dom? dom)
- (update (rem-dom a x ::fd) x dom)
+ (ext-run-cs (rem-dom a x ::fd) x dom)
(ext-dom-fd a x dom)))
(defn update-var-dom
@@ -3107,8 +3097,8 @@
Object
(-force-ans [v x]
- (if (integer? v)
- (updateg x v)
+ (if (lvar? x)
+ (ext-run-csg x v)
s#))
clojure.lang.Sequential
@@ -3146,25 +3136,25 @@
FiniteDomain
(-force-ans [v x]
- ((map-sum (fn [n] (updateg x n))) (to-vals v)))
+ ((map-sum (fn [n] (ext-run-csg x n))) (to-vals v)))
IntervalFD
(-force-ans [v x]
- ((map-sum (fn [n] (updateg x n))) (to-vals v)))
+ ((map-sum (fn [n] (ext-run-csg x n))) (to-vals v)))
MultiIntervalFD
(-force-ans [v x]
- ((map-sum (fn [n] (updateg x n))) (to-vals v))))
+ ((map-sum (fn [n] (ext-run-csg x n))) (to-vals v))))
(defn force-ans [x]
(fn [a]
((let [v (walk a x)]
(if (lvar? v)
- (-force-ans (get-dom-fd a x) x)
- (if (sequential? v)
- (let [x (root-var a x)]
- (-force-ans (sort-by-strategy v x a) x))
- (-force-ans v x)))) a)))
+ (-force-ans (get-dom-fd a x) v)
+ (let [x (root-var a x)]
+ (if (sequential? v)
+ (-force-ans (sort-by-strategy v x a) x)
+ (-force-ans v x))))) a)))
(deftype FDConstraint [proc _id _meta]
clojure.lang.ILookup
View
3  src/main/clojure/clojure/core/logic/bench.clj
@@ -339,8 +339,7 @@
(eqfd
(= (+ (* 1000 s) (* 100 e) (* 10 n) d
(* 1000 m) (* 100 o) (* 10 r) e)
- (+ (* 10000 m) (* 1000 o) (* 100 n) (* 10 e) y)))
- (debug-doms))))
+ (+ (* 10000 m) (* 1000 o) (* 100 n) (* 10 e) y))))))
;; Bratko 3rd ed pg 343
View
37 src/test/clojure/clojure/core/logic/tests.clj
@@ -1329,6 +1329,24 @@
(== `(~a) c)))
'(_0))))
+(deftest test-85-alias
+ (is (= (run* [q]
+ (fresh [x y]
+ (predc y even? `even?)
+ (predc x odd? `odd)
+ (== x y)
+ (== x 1)
+ (== q [x y])))
+ ())))
+
+(deftest test-77-alias
+ (is (= (run 1 [r a b x]
+ (== r [a b])
+ (infd a b x (domain 1 2))
+ (<fd a b)
+ (firsto r x))
+ '([[1 2] 1 2 1]))))
+
;; =============================================================================
;; cKanren
@@ -1876,7 +1894,7 @@
s ((domfd x (interval 1 10)) empty-s)]
(is (= (take 10
(solutions s x
- ((map-sum (fn [v] (updateg x v)))
+ ((map-sum (fn [v] (ext-run-csg x v)))
(to-vals (interval 1 10)))))
'(1 2 3 4 5 6 7 8 9 10)))))
@@ -2058,10 +2076,10 @@
(deftest test-ckanren-10
(is (= (run* [q]
- (fresh [a]
- (infd a (interval 1 10))
- (subgoal a)
- (== q a)))
+ (fresh [x]
+ (infd x (interval 1 10))
+ (subgoal x)
+ (== q x)))
'(2))))
(deftest test-list-sorted
@@ -2175,7 +2193,7 @@
;; -----------------------------------------------------------------------------
;; CLP(Tree)
-(deftest test-recover-vars []
+#_(deftest test-recover-vars []
(let [x (lvar 'x)
y (lvar 'y)
s (-> empty-s
@@ -2651,11 +2669,10 @@
(ext-no-check y x))]
(is (= (root-var s y) x))))
-(deftest test-update-1 []
+(deftest test-ext-run-cs-1 []
(let [x (lvar 'x)
s (ext-no-check empty-s x (subst-val ::l/unbound))
s (add-attr s x ::l/fd (domain 1 2 3))
- s (update s x 1)]
- (is (= (:v (root-val s x)) 1))
- (is (= (get-attr s x ::l/fd) (domain 1 2 3)))
+ s (ext-run-cs s x 1)]
+ (is (= (root-val s x) 1))
(is (= (walk s x) 1))))
Please sign in to comment.
Something went wrong with that request. Please try again.