Permalink
Browse files

Allow props to initialize themselves. Sudoku example can now handle a…

…ssignment.
  • Loading branch information...
1 parent feb134a commit 8223f9cbbb90ab9a424aa2fb01786750169e3742 @jamii committed May 18, 2012
Showing with 41 additions and 19 deletions.
  1. +21 −11 src/shackles/core.clj
  2. +20 −8 src/shackles/examples.clj
View
@@ -59,9 +59,9 @@
(upper-bound [dom] "Returns the (inclusive) upper bound of this domain"))
(defprotocol Propagator
- (priority [prop] "Used for sorting the agenda")
- (subscriptions [prop] "List of [var event-class] pairs to which the propagator should initially be subscribed")
- (propagate [prop space vars&events] "Returns a modified subspace"))
+ (priority [prop] "Priority in agenda (lower number is higher priority")
+ (init [prop space] "Initialise the prop. May subscribe to vars, generate events and schedule itself. Returns a modified space.")
+ (propagate [prop space vars&events] "Run the prop. May do any of the above plus apply actions. Returns a modified space"))
(defn add-var [space var dom]
(merge space
@@ -77,21 +77,24 @@
(let [new-val (if (nil? val) default val)]
(apply f new-val args)))))
-(defn subscribe [space prop var event-class]
+(defn subscribe-var [space prop var event-class]
(update-with-default space [:subs var event-class] #{} conj prop))
-(defn unsubscribe [space prop var event-class]
+(defn subscribe-vars [space prop vars&event-classes]
+ (reduce (fn [space [var event-class]] (subscribe-var space prop var event-class)) space vars&event-classes))
+
+(defn unsubscribe-var [space prop var event-class]
(update-with-default space [:subs var event-class] #{} disj prop))
+(defn unsubscribe-vars [space prop vars&event-classes]
+ (reduce (fn [space [var event-class]] (unsubscribe-var space prop var event-class)) space vars&event-classes))
+
(defn add-prop [space prop]
- (reduce (fn [space [var event-class]] (subscribe space prop var event-class)) space (subscriptions prop)))
+ (init prop space))
(defn add-props [space props]
(reduce add-prop space props))
-(defn remove-prop [space prop]
- (reduce (fn [space [var event-class]] (unsubscribe space var event-class)) space (subscriptions prop)))
-
(defn schedule-prop [space prop]
(update-in space [:agenda] conj [prop (priority prop)]))
@@ -110,6 +113,9 @@
space
props)))
+(defn handle-events [space vars&events]
+ (reduce (fn [space [var event]] (handle-event space var event)) space vars&events))
+
(defn handle-action [space var action]
(let [old-dom (get-in space [:doms var])
new-dom (perform old-dom action)
@@ -157,8 +163,12 @@
Propagator
(priority [this]
0)
- (subscriptions [this]
- (for [var vars] [var Equal]))
+ (init [this space]
+ (-> space
+ (subscribe-vars this (for [var vars] [var Equal]))
+ (handle-events (for [[var dom] (select-vars space vars)
+ :when (assigned? dom)]
+ [var (Equal. (assigned dom))]))))
(propagate [this space vars&events]
(let [vars&actions (for [[assigned-var events] vars&events
event events
View
@@ -27,11 +27,23 @@
space (-> core/empty-space
(core/add-vars vars&doms)
(core/add-props (for [group (concat rows cols squares)]
- (core/->AllDifferent group)))
- (core/stabilise))
- search-strat (search/->Exhaust (flatten rows) (search/->ChooseUnassigned) (search/->SplitAssign))
- solution (first (search/depth-first search/non-failed-leaf? search-strat space))
- ]
- (for [row rows]
- (for [var row]
- (core/assigned ((:doms solution) var))))))
+ (core/->AllDifferent group))))
+ search-strat (search/->Exhaust vars (search/->ChooseUnassigned) (search/->SplitAssign))
+ solution (first (search/depth-first search/non-failed-leaf? search-strat space))]
+ (when solution
+ (for [row rows]
+ (for [var row]
+ (core/assigned (get-in solution [:doms var])))))))
+
+(comment
+ (let [problem [[0 0 0 2 0 5 0 0 0]
+ [0 9 0 0 0 0 7 3 0]
+ [0 0 2 0 0 9 0 6 0]
+ [2 0 0 0 0 0 4 0 9]
+ [0 0 0 0 7 0 0 0 0]
+ [6 0 9 0 0 0 0 0 1]
+ [0 8 0 4 0 0 1 0 0]
+ [0 6 3 0 0 0 0 8 0]
+ [0 0 0 6 0 8 0 0 0]]]
+ (doseq [line (sudoku 3 problem)]
+ (prn line))

0 comments on commit 8223f9c

Please sign in to comment.