cljs.core.logic.macros.clj Maven / Gradle / Ivy
(ns cljs.core.logic.macros
(:refer-clojure :exclude [==])
(:require [clojure.set :as set]))
(def ^{:dynamic true} *locals*)
(defmacro llist
"Constructs a sequence from 2 or more arguments, with the last argument as the tail.
The tail is improper if the last argument is a logic variable."
([f s] `(cljs.core.logic/lcons ~f ~s))
([f s & rest] `(cljs.core.logic/lcons ~f (llist ~s ~@rest))))
(defn bind-conde-clause [a]
(fn [g-rest]
`(bind* ~a ~@g-rest)))
(defn bind-conde-clauses [a clauses]
(map (bind-conde-clause a) clauses))
(defn lvar-bind [sym]
((juxt identity
(fn [s] `(cljs.core.logic/lvar '~s))) sym))
(defn lvar-binds [syms]
(mapcat lvar-bind syms))
(defmacro bind*
([a g] `(cljs.core.logic/-bind ~a ~g))
([a g & g-rest]
`(bind* (cljs.core.logic/-bind ~a ~g) ~@g-rest)))
(defmacro mplus*
([e] e)
([e & e-rest]
`(cljs.core.logic/-mplus ~e (fn [] (mplus* ~@e-rest)))))
(defmacro -inc [& rest]
`(fn [] ~@rest))
(defmacro ==
"A goal that attempts to unify terms u and v."
[u v]
`(fn [a#]
(if-let [b# (cljs.core.logic/-unify a# ~u ~v)]
b# nil)))
(defmacro conde
"Logical disjunction of the clauses. The first goal in
a clause is considered the head of that clause. Interleaves the
execution of the clauses."
[& clauses]
(let [a (gensym "a")]
`(fn [~a]
(-inc
(mplus* ~@(bind-conde-clauses a clauses))))))
(defmacro fresh
"Creates fresh variables. Goals occuring within form a logical
conjunction."
[[& lvars] & goals]
`(fn [a#]
(-inc
(let [~@(lvar-binds lvars)]
(bind* a# ~@goals)))))
(defmacro solve [& [n [x] & goals]]
`(let [xs# (cljs.core.logic/-take* (fn []
((fresh [~x] ~@goals
(fn [a#]
(cons (cljs.core.logic/-reify a# ~x) '()))) ;; TODO: do we need this?
cljs.core.logic/empty-s)))]
(if ~n
(take ~n xs#)
xs#)))
(defmacro run
"Executes goals until a maximum of n results are found."
[n & goals]
`(doall (solve ~n ~@goals)))
(defmacro run*
"Executes goals until results are exhausted."
[& goals]
`(run false ~@goals))
(defmacro run-nc
"Executes goals until a maximum of n results are found. Does not occurs-check."
[& [n & goals]]
`(binding [*occurs-check* false]
(run ~n ~@goals)))
(defmacro run-nc*
"Executes goals until results are exhausted. Does not occurs-check."
[& goals]
`(run-nc false ~@goals))
(defmacro lazy-run
"Lazily executes goals until a maximum of n results are found."
[& [n & goals]]
`(solve ~n ~@goals))
(defmacro lazy-run*
"Lazily executes goals until results are exhausted."
[& goals]
`(solve false ~@goals))
(defmacro all
"Like fresh but does does not create logic variables."
([] `cljs.core.logic/s#)
([& goals] `(fn [a#] (bind* a# ~@goals))))
;; =============================================================================
;; Debugging
(defmacro log [& s]
"Goal for println"
`(fn [a#]
(println ~@s)
a#))
(defmacro trace-s []
"Goal that prints the current substitution"
`(fn [a#]
(println (str a#))
a#))
(defn trace-lvar [a lvar]
`(println (format "%5s = %s" (str '~lvar) (-reify ~a ~lvar))))
(defmacro trace-lvars
"Goal for tracing the values of logic variables."
[title & lvars]
(let [a (gensym "a")]
`(fn [~a]
(println ~title)
~@(map (partial trace-lvar a) lvars)
~a)))
;; =============================================================================
;; Non-relational goals
;; =============================================================================
;; project
(defn project-binding [s]
(fn [var]
`(~var (-walk* ~s ~var))))
(defn project-bindings [vars s]
(reduce concat (map (project-binding s) vars)))
(defmacro project
"Extract the values bound to the specified logic vars. Non-relational."
[[& vars] & goals]
(let [a (gensym "a")]
`(fn [~a]
(let [~@(project-bindings vars a)]
((fresh []
~@goals) ~a)))))
(defmacro pred
"Check a predicate against the value logic var. Non-relational."
[v f]
`(project [~v]
(== (~f ~v) true)))
(defmacro is
"Set the value of a var to value of another var with the operation
applied. Non-relational."
[u v op]
`(project [~v]
(== ~u (~op ~v))))
;; =============================================================================
;; conda (soft-cut), condu (committed-choice)
;;
;; conda once a line succeeds no others are tried
;; condu a line can succeed only one time
;; TODO : if -> when
(defmacro ifa*
([])
([[e & gs] & grest]
`(cljs.core.logic/-ifa ~e [~@gs]
~(if (seq grest)
`(delay (ifa* ~@grest))
nil))))
(defmacro ifu*
([])
([[e & gs] & grest]
`(cljs.core-logic/-ifu ~e [~@gs]
~(if (seq grest)
`(delay (ifu* ~@grest))
nil))))
(defn cond-clauses [a]
(fn [goals]
`((~(first goals) ~a) ~@(rest goals))))
(defmacro conda
"Soft cut. Once the head of a clause has succeeded
all other clauses will be ignored. Non-relational."
[& clauses]
(let [a (gensym "a")]
`(fn [~a]
(ifa* ~@(map (cond-clauses a) clauses)))))
(defmacro condu
"Committed choice. Once the head (first goal) of a clause
has succeeded, remaining goals of the clause will only
be run once. Non-relational."
[& clauses]
(let [a (gensym "a")]
`(fn [~a]
(ifu* ~@(map (cond-clauses a) clauses)))))
;; =============================================================================
;; lvar nonlvar
;; =============================================================================
;; Pattern matching
(defn warn [& msg]
(binding [*out* *err*]
(apply println "WARNING:" msg)))
(declare p->term)
(defn lcons-p? [p]
(and (coll? p)
(not (nil? (some '#{.} p)))))
(defn p->llist [p]
`(llist
~@(map p->term
(remove #(contains? '#{.} %) p))))
(defn p->term [p]
(cond
(= p '_) `(cljs.core.logic/lvar)
(lcons-p? p) (p->llist p)
(and (coll? p)
(not= (first p) 'quote)) (cond
(list? p) p
:else `[~@(map p->term p)])
:else p))
(defn lvar-sym? [s]
(and (symbol? s)
(not= s '.)
(not (contains? *locals* s))))
(defn extract-vars
([p]
(set (cond
(lvar-sym? p) [p]
(coll? p) (let [p (if (seq? p) (rest p) p)]
(filter lvar-sym? (flatten p)))
:else nil)))
([p seen]
(set/difference (extract-vars p) (set seen))))
(defn fresh-expr? [cs]
(= (first cs) `fresh))
(defn ex
([vs t a]
`(fresh [~@vs]
(== ~t ~a)))
([vs t a exprs]
(if (fresh-expr? exprs)
`(fresh [~@vs]
(== ~t ~a)
~exprs)
`(fresh [~@vs]
(== ~t ~a)
~@exprs))))
(defn ex* [[[p a :as pa] & par] exprs seen]
(let [t (p->term p)
vs (extract-vars p seen)
seen (reduce conj seen vs)]
(cond
(nil? pa) exprs
(= p '_) (ex* par exprs seen)
(empty? par) (if exprs
(ex vs t a exprs)
(ex vs t a))
:else (let [r (ex* par exprs seen)]
(if r
(ex vs t a r)
(ex vs t a))))))
(defn all-blank? [p]
(every? #(= % '_) p))
(defn handle-clause [as]
(when-not (vector? as)
(throw (Exception. (str "Expecting vector of arguments, instead " as))))
(fn [[p & exprs]]
(when-not (vector? p)
(throw (Exception. (str "Expecting vector of matches, instead " p))))
(when-not (= (count p) (count as))
(warn "Differing number of matches. Matching" p "against" as))
(let [pas (partition 2 (interleave p as))
r (ex* pas exprs #{})]
(if (all-blank? p)
r
(list r)))))
(defn handle-clauses [t as cs]
`(~t
~@(doall (map (handle-clause as) cs))))
;; name-with-attributes by Konrad Hinsen, from clojure.contrib.def
(defn name-with-attributes
"To be used in macro definitions.
Handles optional docstrings and attribute maps for a name to be defined
in a list of macro arguments. If the first macro argument is a string
it is added as a docstring to name and removed from the macro argument
list. If afterwards the first macro argument is a map, its entries are
added to the name's metadata map and the map is removed from the
macro argument list. The return value is a vector containing the name
with its extended metadata map and the list of unprocessed macro
arguments."
[name macro-args]
(let [[docstring macro-args] (if (string? (first macro-args))
[(first macro-args) (next macro-args)]
[nil macro-args])
[attr macro-args] (if (map? (first macro-args))
[(first macro-args) (next macro-args)]
[{} macro-args])
attr (if docstring
(assoc attr :doc docstring)
attr)
attr (if (meta name)
(conj (meta name) attr)
attr)]
[(with-meta name attr) macro-args]))
(defmacro lvaro
"Goal to test whether a logic var is ground. Non-relational."
[v]
`(fn [a#]
(if (cljs.core.logic/lvar? (cljs.core.logic/-walk a# ~v))
a# nil)))
(defmacro nonlvaro
"Goal to test whether a logic var is ground. Non-relational."
[v]
`(fn [a#]
(if (not (cljs.core.logic/lvar? (cljs.core.logic/walk a# ~v)))
a# nil)))
(defn env-locals [& syms]
(disj (set (apply concat syms)) '_))
(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))))))
;; =============================================================================
;; Goal sugar syntax
(defmacro defne
"Define a goal fn. Supports pattern matching. All
patterns will be tried. See conde."
[& rest]
`(defnm conde ~@rest))
(defmacro matche
"Pattern matching macro. All patterns will be tried.
See conde."
[xs & cs]
(binding [*locals* (env-locals xs (keys &env))]
(handle-clauses `conde xs cs)))
;; -----------------------------------------------------------------------------
;; defnu, defna, matcha, matchu
;; TODO: we need to rethink defna and defnu, the unification comes first
;; the *question* should come first
(defmacro defna
"Define a soft cut goal. See conda."
[& rest]
`(defnm conda ~@rest))
(defmacro defnu
"Define a committed choice goal. See condu."
[& rest]
`(defnm condu ~@rest))
(defmacro matcha
"Define a soft cut pattern match. See conda."
[xs & cs]
(binding [*locals* (env-locals xs (keys &env))]
(handle-clauses `conda xs cs)))
(defmacro matchu
"Define a committed choice goal. See condu."
[xs & cs]
(binding [*locals* (env-locals xs (keys &env))]
(handle-clauses `condu xs cs)))© 2015 - 2025 Weber Informatics LLC | Privacy Policy