Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Logic 81 #14

Closed
wants to merge 5 commits into from

2 participants

Nada Amin David Nolen
Nada Amin
Collaborator

Ready for review by @swannodette. I'll do a clean rebase / patch on JIRA once we're all happy.

David Nolen
Collaborator

I should explain a couple of things so it's clear why that original bit of code I wrote exists at all. The Scheme implementation of cKanren involves a lot of scanning of the constraint store. As an optimization I chose a different representation - the constraint store contains a map of variables to sets of constraint ids (integers) as well as a map of those ids to the actual constraints. Now finding the constraint set for a particular variable is a cheap operation.

However a complexity arises because logic vars can alias logic vars, imagine the case of (== u v) where u and v are both fresh. It easy to get into a situation where the aliasing is not reflected in the constraint store. My solution was to try and create stable "root" vars - there can only be one "root" var. Of course this means we have to do some merging of constraints and domain information if we have two fresh vars that have constraint information on them.

Ok, so what addcg does with fresh vars - it ensures they are created as roots. So to me this bug seems to be a violation of an invariant that unbound-rands should uphold. It should only return the vars which truly have no binding in the substitution map. Vars which have constraints but no binding appear as SubstValues in the substitution map with their value field, :v, set to ::unbound. So I don't think that addcg should check for clobbering, rather unbound-rands should be fixed (if it can of course).

Hopefully this makes sense. Happy to clarify further.

Collaborator

Thanks for the clarification. It would be very helpful if we could do a text chat, perhaps via Gmail (nada.amin@gmail.com)?

Collaborator

In a nutshell, my understanding of the root issue is that 'rands' does not take the substitution map into account.

Consider this program:

(run* [q]
           (fresh [x]
             (== q x)
             (predc q number? `number?)
             (== x "foo")))

First, (q . x). So x is the implicit root. But then, predc is attaching the constraint keyed by q, which is not a root!

Then unbound-rands just returns q, and this clobbers the (q . x).

In order for predc to attach the constraint correctly, it needs to walk the rands. The API issue now is that addc, updatec, remc do not take a Substitution.

Do you agree with this assessment?

Collaborator

Yes I think you are right! addc, updatec, and remc need the Substitution to know what vars a constraint actually refers to. This also opens the door for some optimizations I've been thinking about for a while - but more importantly I really do think this should address the underlying issue.

Collaborator

BTW, let me know if you would like to tackle this. More than happy to take a patch for master. Or if you'd rather focus on the alphaKanren work, I'm also more than happy to dig into this one.

David Nolen
Collaborator

This looks great! Patch welcome :)

David Nolen
Collaborator

Patch applied

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
This page is out of date. Refresh to see the latest.
58 src/main/clojure/clojure/core/logic.clj
@@ -151,11 +151,11 @@
151 151 ;; Constraint Store
152 152
153 153 (defprotocol IConstraintStore
154   - (addc [this c])
155   - (updatec [this c])
156   - (remc [this c])
  154 + (addc [this a c])
  155 + (updatec [this a c])
  156 + (remc [this a c])
157 157 (runc [this c state])
158   - (constraints-for [this x ws])
  158 + (constraints-for [this a x ws])
159 159 (migrate [this u v]))
160 160
161 161 ;; -----------------------------------------------------------------------------
@@ -814,12 +814,16 @@
814 814 (defmethod print-method MultiIntervalFD [x ^Writer writer]
815 815 (.write writer (str "<intervals:" (apply pr-str (:is x)) ">")))
816 816
817   -(defn var-rands [c]
  817 +(defn var-rands [a c]
818 818 (->> (rands c)
819   - flatten
  819 + (map #(root-var a %))
820 820 (filter lvar?)
821 821 (into [])))
822 822
  823 +(defn unbound-rands [a c]
  824 + (->> (var-rands a c)
  825 + (filter #(lvar? (root-val a %)))))
  826 +
823 827 (declare add-var)
824 828
825 829 ;; ConstraintStore
@@ -842,23 +846,23 @@
842 846 :running running
843 847 not-found))
844 848 IConstraintStore
845   - (addc [this c]
846   - (let [vars (var-rands c)
  849 + (addc [this a c]
  850 + (let [vars (var-rands a c)
847 851 c (with-id c cid)
848 852 cs (reduce (fn [cs v] (add-var cs v c)) this vars)]
849 853 (ConstraintStore. (:km cs) (:cm cs) (inc cid) running)))
850   - (updatec [this c]
  854 + (updatec [this a c]
851 855 (let [oc (cm (id c))
852 856 nkm (if (instance? clojure.core.logic.IRelevantVar c)
853 857 (reduce (fn [km x]
854 858 (if-not (-relevant-var? c x)
855 859 (dissoc km x)
856 860 km))
857   - km (var-rands oc))
  861 + km (var-rands a oc))
858 862 km)]
859 863 (ConstraintStore. nkm (assoc cm (id c) c) cid running)))
860   - (remc [this c]
861   - (let [vs (var-rands c)
  864 + (remc [this a c]
  865 + (let [vs (var-rands a c)
862 866 ocid (id c)
863 867 nkm (reduce (fn [km v]
864 868 (let [vcs (disj (get km v) ocid)]
@@ -872,8 +876,8 @@
872 876 (if state
873 877 (ConstraintStore. km cm cid (conj running (id c)))
874 878 (ConstraintStore. km cm cid (disj running (id c)))))
875   - (constraints-for [this x ws]
876   - (when-let [ids (get km x)]
  879 + (constraints-for [this a x ws]
  880 + (when-let [ids (get km (root-var a x))]
877 881 (filter #((watched-stores %) ws) (map cm (remove running ids)))))
878 882 (migrate [this u v]
879 883 (let [ucs (km u)
@@ -1167,11 +1171,6 @@
1167 1171 l (reduce (fn [l [k v]] (cons (Pair. k v) l)) '() v)]
1168 1172 (make-s s l (make-cs))))
1169 1173
1170   -(defn unbound-rands [a c]
1171   - (->> (rands c)
1172   - flatten
1173   - (filter #(lvar? (root-val a %)))))
1174   -
1175 1174 (defn annotate [k v]
1176 1175 (fn [a]
1177 1176 (vary-meta a assoc k v)))
@@ -2859,15 +2858,15 @@
2859 2858 (let [a (reduce (fn [a x]
2860 2859 (ext-no-check a x (subst-val ::unbound)))
2861 2860 a (unbound-rands a c))]
2862   - (assoc a :cs (addc (:cs a) c)))))
  2861 + (assoc a :cs (addc (:cs a) a c)))))
2863 2862
2864 2863 (defn updatecg [c]
2865 2864 (fn [a]
2866   - (assoc a :cs (updatec (:cs a) c))))
  2865 + (assoc a :cs (updatec (:cs a) a c))))
2867 2866
2868 2867 (defn remcg [c]
2869 2868 (fn [a]
2870   - (assoc a :cs (remc (:cs a) c))))
  2869 + (assoc a :cs (remc (:cs a) a c))))
2871 2870
2872 2871 (defn runcg [c]
2873 2872 (fn [a]
@@ -2930,12 +2929,13 @@
2930 2929 (if (or (zero? (count cs))
2931 2930 (nil? (seq xs)))
2932 2931 s#
2933   - (let [xcs (constraints-for cs (first xs) ws)]
2934   - (if (seq xcs)
2935   - (composeg
2936   - (run-constraints xcs)
2937   - (run-constraints* (next xs) cs ws))
2938   - (run-constraints* (next xs) cs ws)))))
  2932 + (fn [a]
  2933 + (let [xcs (constraints-for cs a (first xs) ws)]
  2934 + (if (seq xcs)
  2935 + (bind* a
  2936 + (run-constraints xcs)
  2937 + (run-constraints* (next xs) cs ws))
  2938 + (bind a (run-constraints* (next xs) cs ws)))))))
2939 2939
2940 2940 (declare get-dom)
2941 2941
@@ -3796,7 +3796,7 @@
3796 3796 pp (prefix oc)]
3797 3797 (cond
3798 3798 (prefix-subsumes? pp p) ((remcg c) a)
3799   - (prefix-subsumes? p pp) (recur (assoc a :cs (remc cs oc)) (next neqcs))
  3799 + (prefix-subsumes? p pp) (recur (assoc a :cs (remc cs a oc)) (next neqcs))
3800 3800 :else (recur a (next neqcs))))
3801 3801 ((updatecg c) a))))))
3802 3802
58 src/test/clojure/clojure/core/logic/tests.clj
@@ -1681,7 +1681,7 @@
1681 1681 (let [u (lvar 'u)
1682 1682 w (lvar 'w)
1683 1683 c (fdc (=fdc u w))]
1684   - (is (= (var-rands c)
  1684 + (is (= (var-rands empty-s c)
1685 1685 [u w]))
1686 1686 (is (= (rator c)
1687 1687 `=fd))
@@ -1693,7 +1693,7 @@
1693 1693 v 1
1694 1694 w (lvar 'w)
1695 1695 c (+fdc u v w)]
1696   - (is (= (var-rands c)
  1696 + (is (= (var-rands empty-s c)
1697 1697 [u w]))
1698 1698 (is (= (rator c)
1699 1699 `+fd))
@@ -1705,7 +1705,7 @@
1705 1705 v 1
1706 1706 w (lvar 'w)
1707 1707 c (fdc (+fdc u v w))]
1708   - (is (= (var-rands c)
  1708 + (is (= (var-rands empty-s c)
1709 1709 [u w]))
1710 1710 (is (= (rator c)
1711 1711 `+fd))
@@ -1717,8 +1717,8 @@
1717 1717 v 1
1718 1718 w (lvar 'w)
1719 1719 c (fdc (+fdc u v w))
1720   - cs (addc (make-cs) c)
1721   - sc (first (constraints-for cs u ::l/fd))]
  1720 + cs (addc (make-cs) empty-s c)
  1721 + sc (first (constraints-for cs empty-s u ::l/fd))]
1722 1722 (is (= c sc))
1723 1723 (is (= (id sc) 0))
1724 1724 (is (= (count (:km cs)) 2))
@@ -1731,9 +1731,9 @@
1731 1731 c0 (fdc (+fdc u v w))
1732 1732 x (lvar 'x)
1733 1733 c1 (fdc (+fdc w v x))
1734   - cs (-> (make-cs )
1735   - (addc c0)
1736   - (addc c1))
  1734 + cs (-> (make-cs)
  1735 + (addc empty-s c0)
  1736 + (addc empty-s c1))
1737 1737 sc0 (get (:cm cs) 0)
1738 1738 sc1 (get (:cm cs) 1)]
1739 1739 (is (= sc0 c0)) (is (= (id sc0) 0))
@@ -1757,7 +1757,7 @@
1757 1757 w (lvar 'w)
1758 1758 c (fdc (+fdc u v w))
1759 1759 s ((addcg c) empty-s)
1760   - c (first (constraints-for (:cs s) u ::fd))
  1760 + c (first (constraints-for (:cs s) s u ::fd))
1761 1761 s (-> s
1762 1762 (ext-no-check u 1)
1763 1763 (ext-no-check w 2))
@@ -2171,9 +2171,9 @@
2171 2171 y (lvar 'y)
2172 2172 z (lvar 'z)
2173 2173 c (fdc (+fdc x y z))
2174   - cs (addc (make-cs) c)
  2174 + cs (addc (make-cs) empty-s c)
2175 2175 cp (get (:cm cs) 0)
2176   - cs (remc cs cp)]
  2176 + cs (remc cs empty-s cp)]
2177 2177 (is (= (:km cs) {}))
2178 2178 (is (= (:cm cs) {}))))
2179 2179
@@ -2187,7 +2187,7 @@
2187 2187 (let [x (lvar 'x)
2188 2188 y (lvar 'y)
2189 2189 c (!=c (list (pair x 1) (pair y 2)))
2190   - cs (addc (make-cs) c)]
  2190 + cs (addc (make-cs) empty-s c)]
2191 2191 (is (tree-constraint? ((:cm cs) 0)))
2192 2192 (is (= (into #{} (keys (:km cs)))
2193 2193 #{x y}))))
@@ -2255,7 +2255,7 @@
2255 2255 y (lvar 'y)
2256 2256 c (!=c (list (pair x 1)))
2257 2257 sc (!=c (list (pair x 1) (pair y 2)))
2258   - cs (addc (make-cs) c)]
  2258 + cs (addc (make-cs) empty-s c)]
2259 2259 ))
2260 2260
2261 2261 (deftest test-multi-constraints-1 []
@@ -2364,6 +2364,24 @@
2364 2364 s (unify empty-s x0 x1)]
2365 2365 (is (= s empty-s))))
2366 2366
  2367 +(deftest test-logic-81-fd []
  2368 + (is (= (run* [q]
  2369 + (fresh [x y]
  2370 + (== q x)
  2371 + (distinctfd [q y])
  2372 + (== y x)
  2373 + (infd q x y (interval 1 3))))
  2374 + ()))
  2375 + (is (= (run* [q]
  2376 + (fresh [x y z]
  2377 + (== q x)
  2378 + (== y z)
  2379 + (distinctfd [q y])
  2380 + (distinctfd [q x])
  2381 + (== z q)
  2382 + (infd q x y z (interval 1 3))))
  2383 + ())))
  2384 +
2367 2385 ;; =============================================================================
2368 2386 ;; predc
2369 2387
@@ -2386,7 +2404,19 @@
2386 2404 (is (= (run* [q]
2387 2405 (== q "foo")
2388 2406 (predc q number? `number?))
2389   - ())))
  2407 + ()))
  2408 + (is (= (run* [q]
  2409 + (fresh [x]
  2410 + (predc q number? `number?)
  2411 + (== q x)
  2412 + (== x "foo")))
  2413 + ()))
  2414 + (is (= (run* [q]
  2415 + (fresh [x]
  2416 + (== q x)
  2417 + (predc q number? `number?)
  2418 + (== x "foo")))
  2419 + ())))
2390 2420
2391 2421 ;; =============================================================================
2392 2422 ;; Real cKanren programs

Tip: You can add notes to lines in a file. Hover to the left of a line to make a note

Something went wrong with that request. Please try again.