Permalink
Browse files

LOGIC-101

  • Loading branch information...
1 parent b26f766 commit 770e027858bde711121abb9267854966a4dd92ed @namin namin committed with swannodette Jan 7, 2013
@@ -143,24 +143,32 @@
(fn [x]
(not (= x a))))
+(defn- -reify-hash [s a x]
+ (let [x (walk* s x)
+ a (walk* s a)]
+ ;; Filter constraints unrelated to reified variables.
+ (when (and (symbol? a) (empty? (->> (list x) flatten (filter lvar?))))
+ (symbol (str a "#" x)))))
+
(defn hash [a t]
- (let [fc #(predc % (make-nom-hash a))
- reifier
- (fn [_ x r s ap]
- (let [x (walk* s x)
- a (walk* s a)]
- ;; Filter constraints unrelated to reified variables.
- (when (and (symbol? a) (empty? (->> (list x) flatten (filter lvar?))))
- (symbol (str a "#" x)))))]
+ (if (nom? a)
(fixc t
(fn loop [t s reifier]
(or
(and (tie? t) (= (:binding-nom t) a) (fn [s] s))
(if (tree-term? t)
(constrain-tree t
(fn [t s] ((fixc t loop reifier) s)))
- (fc t))))
- reifier)))
+ (predc t (make-nom-hash a)))))
+ (fn [_ x r s ap]
+ (-reify-hash s a x)))
+ (fixc a
+ (fn loop [a s reifier]
+ (if (nom? a)
+ (hash a t)
+ (throw (Exception. (str "nom/hash expects a nom first, not: " a)))))
+ (fn [_ _ r s ap]
+ (-reify-hash s a t)))))
;; =============================================================================
;; Suspensions as constraints
@@ -403,3 +403,12 @@
(== x 'foo)
(== [x y] q))))
())))
+
+(deftest test-101-variable-nom-in-hash
+ (is (= (run* [q]
+ (nom/fresh [x]
+ (fresh [y]
+ (predc y nom? `nom?)
+ (nom/hash y x)
+ (== x y))))
+ ())))

0 comments on commit 770e027

Please sign in to comment.