Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: clojure/core.logic
...
head fork: clojure/core.logic
  • 2 commits
  • 2 files changed
  • 0 commit comments
  • 1 contributor
Commits on Aug 09, 2012
David Nolen * src/main/clojure/clojure/core/logic.clj: first cut of eqfd sugar, u…
…pdate cryptarithfd bench
381b690
David Nolen flip eqfd* emission order to allow domain information to flow. +fd & …
…*fd support for eqfd sugar. add send more money fd version using eqfd sugar. still suprisingl slow, seems like perhaps too much work is being done on the intermediate vars.
8c1638e
View
75 src/main/clojure/clojure/core/logic.clj
@@ -3371,7 +3371,9 @@
clojure.lang.IFn
(invoke [this s]
(let-dom s [u du v dv w dw]
- (let [[wmin wmax] (bounds dw)
+ (let [[wmin wmax] (if (domain? dw)
+ (bounds dw)
+ [(+ (lb du) (lb dv)) (+ (ub du) (ub dv))])
[umin umax] (bounds du)
[vmin vmax] (bounds dv)]
((composeg
@@ -3391,7 +3393,11 @@
(not (singleton-dom? dw)) true
:else (or (= du dw) (= dv dw)))))
(relevant? [this x s]
- (relevant? this s))))
+ (relevant? this s))
+ IRunnable
+ (runnable? [this s]
+ (let-dom s [u du v dv]
+ (and (domain? du) (domain? dv))))))
(defn +fd
"A finite domain constraint for addition and subtraction.
@@ -3406,7 +3412,9 @@
clojure.lang.IFn
(invoke [this s]
(let-dom s [u du v dv w dw]
- (let [[wmin wmax] (bounds dw)
+ (let [[wmin wmax] (if (domain? dw)
+ (bounds dw)
+ [(* (lb du) (lb dv)) (* (ub du) (ub dv))])
[umin umax] (bounds du)
[vmin vmax] (bounds dv)
ui (interval (safe-div vmax umin wmin)
@@ -3431,7 +3439,11 @@
(not (singleton-dom? dw)) true
:else (or (= du dw) (= dv dw)))))
(relevant? [this x s]
- (relevant? this s)))))
+ (relevant? this s))
+ IRunnable
+ (runnable? [this s]
+ (let-dom s [u du v dv]
+ (and (domain? du) (domain? dv)))))))
(defn *fd
"A finite domain constraint for multiplication and
@@ -3675,4 +3687,57 @@
([_ [x . xs] xs])
([_ [y . ys] [y . zs]]
(!= y x)
- (rembero x ys zs)))
+ (rembero x ys zs)))
+
+;; -----------------------------------------------------------------------------
+;; FD Equation Sugar
+
+(def binops '#{+ * =})
+
+(def binops->fd
+ '{+ clojure.core.logic/+fd
+ * clojure.core.logic/*fd
+ = clojure.core.logic/==})
+
+(defn expand [form]
+ (if (seq? form)
+ (let [[op & args] form]
+ (if (and (binops op) (> (count args) 2))
+ (list op (expand (first args))
+ (expand (cons op (rest args))))
+ (cons op (map expand args))))
+ form))
+
+(defn eqfd*
+ ([form vars] (eqfd* form vars nil))
+ ([form vars out]
+ (if (seq? form)
+ (let [[op r1 r2] form
+ [outl outlv?] (if (seq? r1)
+ (let [s (gensym)]
+ (swap! vars conj s)
+ [s true])
+ [r1 false])
+ [outr outrv?] (if (seq? r2)
+ (let [s (gensym)]
+ (swap! vars conj s)
+ [s true])
+ [r2 false])
+ op (binops->fd op)]
+ (cons (if out
+ (list op outr outl out)
+ (list op outr outl))
+ (concat (when (seq? r1)
+ (eqfd* r1 vars (when outlv? outl)))
+ (when (seq? r2)
+ (eqfd* r2 vars (when outrv? outr))))))
+ form)))
+
+(defn ->fd [vars exprs]
+ `(fresh [~@vars]
+ ~@(reverse exprs)))
+
+(defmacro eqfd [form]
+ (let [vars (atom [])
+ exprs (eqfd* (expand form) vars)]
+ (->fd @vars exprs)))
View
50 src/main/clojure/clojure/core/logic/bench.clj
@@ -267,28 +267,44 @@
;; =============================================================================
;; Cryptarithmetic Puzzle
-;; Bratko 3rd ed pg 343
-;; TODO: we want sugar for this
+(defn cryptarithfd-1 []
+ (run* [q]
+ (fresh [vs s e n d m o r y]
+ (== q [[s e n d] [m o r e] [m o n e y]])
+ (infd s e n d m o r y (interval 0 9))
+ (distinctfd [s e n d m o r y])
+ (!=fd m 0) (!=fd s 0)
+ (eqfd
+ (= (+ (* 1000 s) (* 100 e) (* 10 n) d
+ (* 1000 m) (* 100 o) (* 10 r) e)
+ (+ (* 10000 m) (* 1000 o) (* 100 n) (* 10 e) y))))))
-#_(defn cryptarithfd []
- (run* [d o n a l d
- g e r a l d
- r o b e r t] :as q
- (infd q (interval 0 9))
- (distintfd q)
- (eqfd
- (= (+ (* 100000 d) (* 10000 o) (* 1000 n) (* 100 a) (* 10 l) d
- (* 100000 g) (* 10000 e) (* 1000 r) (* 100 a) (* 10 l) d)
- (+ (* 100000 r) (* 10000 o) (* 1000 b) (* 100 e) (* 10 r) t)))))
+;; Bratko 3rd ed pg 343
+
+#_(defn cryptarithfd-2 []
+ (run* [q]
+ (fresh [d o n a l g e r b t]
+ (== q [d o n a l g e r b t])
+ (infd d o n a l g e r b t (interval 0 9))
+ (distinctfd q)
+ (eqfd
+ (= (+ (* 100000 d) (* 10000 o) (* 1000 n) (* 100 a) (* 10 l) d
+ (* 100000 g) (* 10000 e) (* 1000 r) (* 100 a) (* 10 l) d)
+ (+ (* 100000 r) (* 10000 o) (* 1000 b) (* 100 e) (* 10 r) t))))))
(comment
- ;; eqfd, codewalking convenience macro
+ ;; works but is very slow, still much faster than original Prolog solution
+ (cryptarithfd-1)
+
+ ;; ah, we don't actually want the intermediate values to generate
+ ;; so many possibilities
+ (cryptarithfd-2)
+
+ ;; perhaps in the case where the domain is large? this needs a lot more
+ ;; thought
- (eqfd
- (= (+ (* 100000 d) (* 10000 o) (* 1000 n) (* 100 a) (* 10 l) d
- (* 100000 g) (* 10000 e) (* 1000 r) (* 100 a) (* 10 l) d)
- (+ (* 100000 r) (* 10000 o) (* 1000 b) (* 100 e) (* 10 r) t)))
+ ;; we don't want "labeling" on generated vars?
)
;; =============================================================================

No commit comments for this range

Something went wrong with that request. Please try again.