Permalink
Browse files

* src/main/clojure/clojure/core/logic.clj: fix broken simple unifier …

…case. clean up LVar construction.
  • Loading branch information...
1 parent 22addb5 commit da6a7f18d9cd6b659c4e07c2faeb9d0847fb956c David Nolen committed Aug 1, 2012
Showing with 7 additions and 21 deletions.
  1. +6 −9 src/main/clojure/clojure/core/logic.clj
  2. +1 −12 src/test/clojure/clojure/core/logic/tests.clj
@@ -1039,19 +1039,20 @@
;; =============================================================================
;; Logic Variables
-(deftype LVar [name hash meta]
+(deftype LVar [name oname hash meta]
clojure.lang.ILookup
(valAt [this k]
(.valAt this k nil))
(valAt [this k not-found]
(case k
:name name
+ :oname oname
not-found))
clojure.lang.IObj
(meta [this]
meta)
(withMeta [this new-meta]
- (LVar. name hash meta))
+ (LVar. name oname hash meta))
Object
(toString [_] (str "<lvar:" name ">"))
(equals [this o]
@@ -1092,7 +1093,7 @@
(reify-term [v s]
(if *reify-vars*
(ext s v (reify-lvar-name s))
- (ext s v (:name meta))))
+ (ext s v (:oname v))))
IWalkTerm
(walk-term [v s] v)
IOccursCheckTerm
@@ -1112,15 +1113,11 @@
(defn lvar
([]
(let [name (str (. clojure.lang.RT (nextID)))]
- (LVar. name (.hashCode name) nil)))
+ (LVar. name nil (.hashCode name) nil)))
([name]
(let [oname name
name (str name "_" (. clojure.lang.RT (nextID)))]
- (LVar. name (.hashCode name) nil)))
- ([name cs]
- (let [oname name
- name (str name "_" (. clojure.lang.RT (nextID)))]
- (LVar. name (.hashCode name) cs))))
+ (LVar. name oname (.hashCode name) nil))))
(defmethod print-method LVar [x ^Writer writer]
(.write writer (str "<lvar:" (:name x) ">")))
@@ -1272,7 +1272,7 @@
(is (= (run* [q] (== q #{1}))
'(#{1}))))
-#_(deftest test-31-unifier-associative
+(deftest test-31-unifier-associative
(is (= (binding [*reify-vars* false]
(unifier '{:a ?x} '{:a ?y} '{:a 5}))
{:a 5}))
@@ -1743,17 +1743,6 @@
(is (= (count (:km cs)) 3))
(is (= (count (:cm cs)) 2))))
-;; FIXME: ext-cs no longer exists
-#_(deftest test-ext-cs
- (let [u (lvar 'u)
- v 1
- w (lvar 'w)
- c (fdc (+fdc u v w))
- s empty-s
- cs (ext-cs (:cs s) c s)]
- (is (= (count (:km cs)) 2))
- (is (= (count (:cm cs)) 1))))
-
(deftest test-addcg
(let [u (lvar 'u)
v 1

0 comments on commit da6a7f1

Please sign in to comment.