Permalink
Browse files

LOGIC-80: add macros fnm, fne, fna, fnu for anynomous goals functions.

  • Loading branch information...
1 parent 0d1d545 commit a64ed2f3447bca78bb6f53244db5d5379ecd55f1 @stanislas stanislas committed with swannodette May 6, 2013
@@ -362,16 +362,33 @@
(defn env-locals [& syms]
(disj (set (apply concat syms)) '_))
+(defmacro -fnm [fn-gen t as & cs]
+ (binding [*locals* (env-locals as (keys &env))]
+ `(~fn-gen [~@as] ~(handle-clauses t as cs))))
+
+(defmacro fnm
+ {:arglists '([t as tabled? & cs])}
+ [t as & cs]
+ (if-let [cs (and (= (first cs) :tabled) (rest cs))]
+ `(-fnm tabled ~t ~as ~@cs)
+ `(-fnm fn ~t ~as ~@cs)))
+
(defmacro defnm [t n & rest]
- (let [[n [as & cs]] (name-with-attributes n rest)]
- (binding [*locals* (env-locals as (-> &env :locals keys))]
- (if-let [tabled? (-> n meta :tabled)]
- `(def ~n (tabled [~@as] ~(handle-clauses t as cs)))
- `(defn ~n [~@as] ~(handle-clauses t as cs))))))
+ (let [[n [as & cs]] (name-with-attributes n rest)
+ e (if (-> n meta :tabled)
+ `(fnm ~t ~as :tabled ~@cs)
+ `(fnm ~t ~as ~@cs))]
+ `(def ~n ~e)))
;; =============================================================================
;; Goal sugar syntax
+(defmacro fne
+ "Define an anonymous goal fn. Supports pattern matching. All
+ patterns will be tried. See conde."
+ [& rest]
+ `(fnm conde ~@rest))
+
(defmacro defne
"Define a goal fn. Supports pattern matching. All
patterns will be tried. See conde."
@@ -386,11 +403,21 @@
(handle-clauses `conde xs cs)))
;; -----------------------------------------------------------------------------
-;; defnu, defna, matcha, matchu
+;; fnu, fna, defnu, defna, matcha, matchu
-;; TODO: we need to rethink defna and defnu, the unification comes first
+;; TODO: we need to rethink (de)fna and (de)fnu, the unification comes first
;; the *question* should come first
+(defmacro fna
+ "Define an anonymous soft cut goal. See conda."
+ [& rest]
+ `(fnm conda ~@rest))
+
+(defmacro fnu
+ "Define an anonymous committed choice goal. See condu."
+ [& rest]
+ `(fnm condu ~@rest))
+
(defmacro defna
"Define a soft cut goal. See conda."
[& rest]
@@ -1566,12 +1566,23 @@
(defn env-locals [& syms]
(disj (set (apply concat syms)) '_))
+(defmacro -fnm [fn-gen t as & cs]
+ (binding [*locals* (env-locals as (keys &env))]
+ `(~fn-gen [~@as] ~(handle-clauses t as cs))))
+
+(defmacro fnm
+ {:arglists '([t as tabled? & cs])}
+ [t as & cs]
+ (if-let [cs (and (= (first cs) :tabled) (rest cs))]
+ `(-fnm tabled ~t ~as ~@cs)
+ `(-fnm fn ~t ~as ~@cs)))
+
(defmacro defnm [t n & rest]
- (let [[n [as & cs]] (name-with-attributes n rest)]
- (binding [*locals* (env-locals as (keys &env))]
- (if-let [tabled? (-> n meta :tabled)]
- `(def ~n (tabled [~@as] ~(handle-clauses t as cs)))
- `(defn ~n [~@as] ~(handle-clauses t as cs))))))
+ (let [[n [as & cs]] (name-with-attributes n rest)
+ e (if (-> n meta :tabled)
+ `(fnm ~t ~as :tabled ~@cs)
+ `(fnm ~t ~as ~@cs))]
+ `(def ~n ~e)))
;; =============================================================================
;; Useful goals
@@ -1620,6 +1631,12 @@
;; =============================================================================
;; Goal sugar syntax
+(defmacro fne
+ "Define an anonymous goal fn. Supports pattern matching. All
+ patterns will be tried. See conde."
+ [& rest]
+ `(fnm conde ~@rest))
+
(defmacro defne
"Define a goal fn. Supports pattern matching. All
patterns will be tried. See conde."
@@ -1634,11 +1651,21 @@
(handle-clauses `conde xs cs)))
;; -----------------------------------------------------------------------------
-;; defnu, defna, matcha, matchu
+;; fnu, fna, defnu, defna, matcha, matchu
-;; TODO: we need to rethink defna and defnu, the unification comes first
+;; TODO: we need to rethink (de)fna and (de)fnu, the unification comes first
;; the *question* should come first
+(defmacro fna
+ "Define an anonymous soft cut goal. See conda."
+ [& rest]
+ `(fnm conda ~@rest))
+
+(defmacro fnu
+ "Define an anonymous committed choice goal. See condu."
+ [& rest]
+ `(fnm condu ~@rest))
+
(defmacro defna
"Define a soft cut goal. See conda."
[& rest]
@@ -1395,10 +1395,26 @@
(defne pm4 [x y]
([[h . t] t]))
+(defn -test-pm [test-msg rel1 rel2 rel3]
+ (testing test-msg
+ (is (= (run* [q] (fresh [x y] (== q [x y]) (rel1 x y))) '([:foo :bar])))
+ (is (= (run* [q] (fresh [x y] (rel2 x y) (== x y))) '(_0)))
+ (is (= (run* [q] (rel3 '(1 2) q)) '((2))))))
+
(deftest test-pm []
- (is (= (run* [q] (fresh [x y] (== q [x y]) (pm1 x y))) '([:foo :bar])))
- (is (= (run* [q] (fresh [x y] (pm2 x y) (== x y))) '(_0)))
- (is (= (run* [q] (pm4 '(1 2) q)) '((2)))))
+ (-test-pm "pattern matching with defne relations" pm1 pm2 pm4))
+
+(deftest test-pm-anonymous []
+ (-test-pm "pattern matching with anonymous fne relations"
+ (fne [x y] ([:foo :bar]))
+ (fne [x y] ([_ x]))
+ (fne [x y] ([[h . t] t]))))
+
+(deftest test-pm-anonymous-tabled []
+ (-test-pm "pattern matching with tabled anonymous fne relations"
+ (fne [x y] :tabled ([:foo :bar]))
+ (fne [x y] :tabled ([_ x]))
+ (fne [x y] :tabled ([[h . t] t]))))
(defne form->ast1 [form ast]
(['(fn ~args . ~body) {:op :fn :args args :body body}]))

0 comments on commit a64ed2f

Please sign in to comment.