Permalink
Browse files

Merge branch 'cKanren' into cKanren-interp

  • Loading branch information...
2 parents 63f62d4 + 8cac91f commit dbce53548ba198a43adc09d1e679340b00eb38ca David Nolen committed Jul 24, 2012
Showing with 80 additions and 27 deletions.
  1. +38 −24 src/main/clojure/clojure/core/logic.clj
  2. +42 −3 src/test/clojure/clojure/core/logic/tests.clj
@@ -3364,15 +3364,19 @@
ITreeConstraint
(tree-constraint? [this] false))
-(defprotocol IConstraintPrefix
+(defprotocol IPrefix
(prefix [this]))
+(defprotocol IWithPrefix
+ (with-prefix [this p]))
+
(defn prefix-s [^Substitutions s ^Substitutions <s]
(letfn [(prefix* [s <s]
(if (identical? s <s)
nil
(cons (first s) (prefix* (rest s) <s))))]
- (with-meta (prefix* (.l s) (.l <s)) {:s s})))
+ (when-let [p (prefix* (.l s) (.l <s))]
+ (with-meta p {:s s}))))
(defn recover-vars [p]
(if (empty? p)
@@ -3396,59 +3400,71 @@
(defn prefix->vars [p]
(map lhs p))
+(declare normalize-store)
+
(defn !=c
([p] (!=c p nil))
([p id]
(reify
+ clojure.lang.IFn
+ (invoke [this a]
+ (if-let [ap (reduce (fn [a [u v]]
+ (when a (unify a u v)))
+ a p)]
+ (when-let [p (prefix-s ap a)]
+ ((normalize-store (with-prefix this p)) a))
+ a))
ITreeConstraint
(tree-constraint? [_] true)
IWithConstraintId
(with-id [_ id] (!=c p id))
IConstraintId
(id [_] id)
- IConstraintPrefix
+ IPrefix
(prefix [_] p)
+ IWithPrefix
+ (with-prefix [_ p] (!=c p id))
IEnforceableConstraint
(enforceable? [_] true)
IReifiableConstraint
(reifiable? [_] true)
IConstraintOp
(rator [_] `!=)
- (rands [_] p)
+ (rands [_] (prefix->vars p))
IRelevant
(relevant? [this s]
(not (empty? p)))
(relevant? [this x s]
- (some #{x} (prefix->vars lhs p)))
+ (some #{x} (prefix->vars p)))
IRunnable
(runnable? [this s]
- true))))
+ (some #(not= (walk s %) %) (prefix->vars p))))))
-(defn normalize-store [p]
+(defn normalize-store [c]
(fn [^Substitutions a]
- (let [^ConstraintStore cs (.cs a)
- cids (map (.km cs) (prefix->vars p))
+ (let [p (prefix c)
+ ^ConstraintStore cs (.cs a)
+ cids (remove nil? (map (.km cs) (prefix->vars p)))
neqcs (seq (->> cids
(map (.cm cs))
(filter tree-constraint?)))]
- (loop [a a neqcs neqcs]
- (let [^Substitutions a a]
- (if neqcs
- (let [oc (first neqcs)
- pp (prefix oc)]
- (cond
- (prefix-subsumes? pp p) a
- (prefix-subsumes? p pp) (recur (make-s (.s a) (.l a) (remc cs oc))
- (next neqcs))
- :else (recur a (next neqcs))))
- a))))))
+ (loop [^Substitutions a a neqcs neqcs]
+ (if neqcs
+ (let [oc (first neqcs)
+ pp (prefix oc)]
+ (cond
+ (prefix-subsumes? pp p) a
+ (prefix-subsumes? p pp) (recur (make-s (.s a) (.l a) (remc cs oc))
+ (next neqcs))
+ :else (recur a (next neqcs))))
+ ((update-cs c) a))))))
(defn != [u v]
(fn [a]
(if-let [ap (unify a u v)]
- (let [p (prefix-s a ap)]
+ (let [p (prefix-s ap a)]
(when (not (empty? p))
- ((!=c a) a)))
+ ((!=c p) a)))
a)))
#_(defn all-diffo [l]
@@ -3461,8 +3477,6 @@
(all-diffo (llist a dd))
(all-diffo (llist ad dd)))]))
-(declare !=)
-
(defne rembero [x l o]
([_ [x . xs] xs])
([_ [y . ys] [y . zs]]
@@ -2145,11 +2145,50 @@
(deftest test-tree-constraint? []
(let [x (lvar 'x)
y (lvar 'y)
- c (!=c x y)
+ c (!=c (list (pair x 1) (pair y 2)))
cs (addc (make-cs) c)]
- (.km cs)))
+ (is (tree-constraint? ((.cm cs) 0)))
+ (is (= (into #{} (keys (.km cs)))
+ #{x y}))))
-(deftest test-normalize-store [])
+(deftest test-prefix-protocols []
+ (let [x (lvar 'x)
+ y (lvar 'y)
+ c (!=c (list (pair x 1) (pair y 2)))
+ c (with-prefix c (list (pair x 1)))]
+ (is (= (prefix c)
+ (list (pair x 1))))))
+
+(deftest test-!=-1 []
+ (let [x (lvar 'x)
+ y (lvar 'y)
+ s ((!= x y) empty-s)]
+ (is (= (prefix ((.cm (.cs s)) 0)) (list (pair x y))))))
+
+(deftest test-!=-2 []
+ (let [x (lvar 'x)
+ y (lvar 'y)
+ s ((!= x y) empty-s)
+ s ((== x y) s)]
+ (is (= s nil))))
+
+;; TODO: constraint is still in the store, why?
+#_(deftest test-!=-3 []
+ (let [x (lvar 'x)
+ y (lvar 'y)
+ s ((!= x y) empty-s)
+ s ((== x 1) s)
+ s ((== y 2) s)
+ c (get (.cm (.cs s)) 0)]
+ (is (not (nil? s)))))
+
+#_(deftest test-normalize-store []
+ (let [x (lvar 'x)
+ y (lvar 'y)
+ c (!=c (list (pair x 1)))
+ sc (!=c (list (pair x 1) (pair y 2)))
+ cs (addc (make-cs) c)]
+ ))
(deftest test-!=c-1)

0 comments on commit dbce535

Please sign in to comment.