Skip to content

Commit 550aa97

Browse files
tuturtotuturto
committed
Fix back tracking algorithm
1 parent 5d02ac5 commit 550aa97

File tree

2 files changed

+117
-94
lines changed

2 files changed

+117
-94
lines changed

‎src/pyherc/solver.hy

Lines changed: 51 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,8 @@
4545
"Get unique value of given variable"
4646
(if (unique? variable)
4747
(first variable.values)
48-
(assert false)))
48+
(assert false
49+
(.format "variable is not unique: {0}" variable.values))))
4950

5051
(defn unique? [variable]
5152
"does variable have exactly one value"
@@ -56,43 +57,50 @@
5657
(len variable.values))
5758

5859
(defn narrow [context variable values]
59-
"narrow down variable"
60-
(let [[new-values (& variable.values values)]]
60+
"narrow down variable. true if ok, false if not ok"
61+
(let [[new-values (& variable.values values)]
62+
[res true]]
6163
(if (= new-values (set []))
6264
false
6365
(if (= new-values variable.values)
6466
true
6567
(do (save context variable)
6668
(setv variable.values new-values)
67-
(all (genexpr (constraint context variable)
68-
[constraint variable.constraints])))))))
69+
(for [constraint (. variable constraints)]
70+
(setv res (constraint context variable))
71+
(when (not res)
72+
(break)))
73+
res)))))
6974

7075
(defn save [context variable]
7176
"save variable state in undo stack"
7277
(.append (:variable-stack context) variable)
7378
(.append (:value-stack context) variable.values)
74-
(setv variable.last-save-frame-pointer (:frame-pointer context)))
79+
(setv variable.last-save-frame-pointer (frame-pointer context)))
7580

76-
(defn restore-values [context variable frame-pointer]
81+
(defn restore-values [context variable frame]
7782
"restore variable states from undo stack"
78-
(while (> (len (:variable-stack context)) frame-pointer)
83+
(while (> (len (:variable-stack context)) frame)
7984
(let [[var (.pop (:variable-stack context))]
8085
[vals (.pop (:value-stack context))]]
8186
(setv var.values vals)))
82-
(assoc context :frame-pointer frame-pointer))
87+
(frame-pointer context frame))
8388

8489
(fact are-equal!
85-
"equality constraint"
90+
"equality constraint"
8691
(if (= updated-variable var1)
8792
(narrow context var2 updated-variable.values)
8893
(narrow context var1 updated-variable.values)))
8994

9095
(fact are-inequal!
91-
"inequality constraint"
92-
(when (value? var1)
93-
(narrow context var2 (- var2.values var1.values)))
94-
(when (value? var2)
95-
(narrow context var1 (- var1.values var2.values))))
96+
"inequality constraint"
97+
(cond [(and (= updated-variable var1)
98+
(unique? var1))
99+
(narrow context var2 (- var2.values var1.values))]
100+
[(and (= updated-variable var2)
101+
(unique? var2))
102+
(narrow context var1 (- var1.values var2.values))]
103+
[true true]))
96104

97105
(fact less-than!
98106
"smaller than constraint"
@@ -119,24 +127,37 @@
119127
(solve-one context variables)))
120128

121129
(defn solve-one [context variables]
122-
"solve all variables"
130+
"solve all variables, one by one"
123131
(if (all (map unique? variables))
124-
(do (assoc context :solved true)
125-
variables)
132+
(mark-solved context)
126133
(let [[variable (variable-to-solve variables)]
134+
[values (.copy variable.values)]
127135
[frame (len (:variable-stack context))]]
128-
(assoc context :frame-pointer frame)
129-
(for [value variable.values]
130-
(do (when (not (:solved context))
131-
(if (narrow context variable (set [value]))
132-
(do (if (all (map value? variables))
133-
(if (not (solve-one context variables))
134-
(assert false))))
135-
false))
136-
(when (not (:solved context))
137-
(restore-values context variable frame))))
138-
(when (:solved context)
139-
variables))))
136+
(frame-pointer context frame)
137+
(for [value values]
138+
(if (not (solved? context))
139+
(if (narrow context variable (set [value]))
140+
(solve-one context variables)
141+
(do (restore-values context variable frame)
142+
(continue))) ;; narrowing failed and stack was restored, try next value
143+
(break))))) ;; solution was found, break loop
144+
(if (solved? context) ;; we either have solution or no suitable value was found
145+
variables
146+
nil))
147+
148+
(defn frame-pointer [context &optional [frame nil]]
149+
"set or retrieve frame-pointer"
150+
(when (not (is frame nil))
151+
(assoc context :frame-pointer frame))
152+
(:frame-pointer context))
153+
154+
(defn mark-solved [context]
155+
"mark context as solved"
156+
(assoc context :solved true))
157+
158+
(defn solved? [context]
159+
"has the context been solved?"
160+
(:solved context))
140161

141162
(defn variable-to-solve [variables]
142163
"select next variable to solve"

‎src/pyherc/test/unit/test_solver.hy

Lines changed: 66 additions & 64 deletions
Original file line numberDiff line numberDiff line change
@@ -20,86 +20,88 @@
2020
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
2121
;; THE SOFTWARE.
2222

23+
(require archimedes)
24+
2325
(import [pyherc.solver [Variable are-equal! are-inequal! less-than!
2426
greater-than! in-between! solve solve-one value]]
2527
[hamcrest [assert-that is- equal-to is-not :as is-not- less-than
2628
greater-than]])
2729

30+
(defmacro non-fact [&rest code]
31+
`"non-fact")
32+
2833
(defn context []
2934
"create an empty context for testing"
3035
{:frame-pointer 0
3136
:variable-stack []
3237
:value-stack []
3338
:solved false})
3439

35-
(defn test-simple-equality []
36-
"simple equality test"
37-
(let [[var₁ (Variable 1 2 3)]
38-
[var₂ (Variable 3 4 5)]]
39-
(are-equal! var₁ var₂)
40-
(solve var₁ var₂)
41-
(assert-that (value var₁) (is- (equal-to (value var₂))))))
40+
(fact "two variables declared equal will have same value"
41+
(let [[var₁ (Variable 1 2 3)]
42+
[var₂ (Variable 3 4 5)]]
43+
(are-equal! var₁ var₂)
44+
(solve var₁ var₂)
45+
(assert-that (value var₁) (is- (equal-to (value var₂))))))
4246

43-
(defn test-simple-inequality []
44-
"inequal variables have different values"
45-
(let [[var₁ (Variable 1 2 3)]
46-
[var₂ (Variable 1 2 3)]]
47-
(are-inequal! var₁ var₂)
48-
(solve var₁ var₂)
49-
(assert-that (value var₁) (is-not- (equal-to (value var₂))))))
47+
(fact "two variables declared inequal will have different value"
48+
(let [[var₁ (Variable 1 2 3)]
49+
[var₂ (Variable 1 2 3)]]
50+
(are-inequal! var₁ var₂)
51+
(solve var₁ var₂)
52+
(assert-that (value var₁) (is-not- (equal-to (value var₂))))))
5053

51-
(defn test-less-than-constraint []
52-
"variable can be constrained to be less than something else"
53-
(let [[var₁ (Variable 1 2 3 4 5)]
54-
[var₂ (Variable 1 2 3 4 5)]]
55-
(less-than! var₁ var₂)
56-
(solve var₁ var₂)
57-
(assert-that (value var₁) (is- (less-than (value var₂))))))
54+
(fact "variable can be constrained to be less than something else"
55+
(let [[var₁ (Variable 1 2 3 4 5)]
56+
[var₂ (Variable 1 2 3 4 5)]]
57+
(less-than! var₁ var₂)
58+
(solve var₁ var₂)
59+
(assert-that (value var₁) (is- (less-than (value var₂))))))
5860

59-
(defn test-triple-less-than []
60-
"set of variables can be ordered with less-than!"
61-
(let [[var₁ (Variable 1 2 3 4 5)]
62-
[var₂ (Variable 1 2 3 4 5)]
63-
[var₃ (Variable 1 2 3 4 5)]]
64-
(less-than! var₁ var₂)
65-
(less-than! var₂ var₃)
66-
(solve var₁ var₂ var₃)
67-
(assert-that (value var₁) (is- (less-than (value var₂))))
68-
(assert-that (value var₂) (is- (less-than (value var₃))))))
61+
(fact "set of variables can be ordered with less-than!"
62+
(let [[var₁ (Variable 1 2 3 4 5)]
63+
[var₂ (Variable 1 2 3 4 5)]
64+
[var₃ (Variable 1 2 3 4 5)]]
65+
(less-than! var₁ var₂)
66+
(less-than! var₂ var₃)
67+
(solve var₁ var₂ var₃)
68+
(assert-that (value var₁) (is- (less-than (value var₂))))
69+
(assert-that (value var₂) (is- (less-than (value var₃))))))
6970

70-
(defn test-basic-greater-than []
71-
"variable can be constrained to be greater than something else"
72-
(let [[var₁ (Variable 1 2 3 4 5)]
73-
[var₂ (Variable 1 2 3 4 5)]]
74-
(greater-than! var₁ var₂)
75-
(solve var₁ var₂)
76-
(assert-that (value var₁) (is- (greater-than (value var₂))))))
71+
(fact "variable can be constrained to be greater than something else"
72+
(let [[var₁ (Variable 1 2 3 4 5)]
73+
[var₂ (Variable 1 2 3 4 5)]]
74+
(greater-than! var₁ var₂)
75+
(solve var₁ var₂)
76+
(assert-that (value var₁) (is- (greater-than (value var₂))))))
7777

78-
(defn test-basic-in-between []
79-
"variable can be constrained to be in-between two variables"
80-
(let [[var₁ (Variable 1 2 3 4 5)]
81-
[var₂ (Variable 1 2 3 4 5)]
82-
[var₃ (Variable 1 2 3 4 5)]]
83-
(in-between! var₁ var₂ var₃)
84-
(solve var₁ var₂ var₃)
85-
(assert-that (value var₁) (is- (greater-than (value var₂))))
86-
(assert-that (value var₁) (is- (less-than (value var₃))))))
78+
(fact "variable can be constrained to be in-between two variables"
79+
(let [[var₁ (Variable 1 2 3 4 5)]
80+
[var₂ (Variable 1 2 3 4 5)]
81+
[var₃ (Variable 1 2 3 4 5)]]
82+
(in-between! var₁ var₂ var₃)
83+
(solve var₁ var₂ var₃)
84+
(assert-that (value var₁) (is- (greater-than (value var₂))))
85+
(assert-that (value var₁) (is- (less-than (value var₃))))))
8786

88-
(defn test-multiple-constraints []
89-
"variables with multiple constraints can be solved"
90-
(let [[var₁ (Variable 1 2 3 4 5)]
91-
[var₂ (Variable 1 2 3 4 5)]
92-
[var₃ (Variable 1 2 3 4 5)]]
93-
(are-equal! var₁ var₂)
94-
(are-inequal! var₁ var₃)
95-
(solve var₁ var₂ var₃)
96-
(assert-that (value var₁) (is- (equal-to (value var₂))))
97-
(assert-that (value var₁) (is-not- (equal-to (value var₃))))))
87+
(fact "variables with multiple constraints can be solved"
88+
(let [[var₁ (Variable 1 2 3 4 5)]
89+
[var₂ (Variable 1 2 3 4 5)]
90+
[var₃ (Variable 1 2 3 4 5)]]
91+
(are-equal! var₁ var₂)
92+
(are-inequal! var₁ var₃)
93+
(solve var₁ var₂ var₃)
94+
(assert-that (value var₁) (is- (equal-to (value var₂))))
95+
(assert-that (value var₁) (is-not- (equal-to (value var₃))))))
9896

99-
(defn test-single-value-left []
100-
"when variables have single value left, they are reported"
101-
(let [[var₁ (Variable 1)]
102-
[var₂ (Variable 2)]]
103-
(solve var₁ var₂)
104-
(assert-that (value var₁) (is- (equal-to 1)))
105-
(assert-that (value var₂) (is- (equal-to 2)))))
97+
(fact "matrix of four variables requiring backtracking can be solved"
98+
(let [[var₁ (Variable 1 2 3 4)]
99+
[var₂ (Variable 1 2 3 4)]
100+
[var₃ (Variable 1 2 3 4)]]
101+
(are-inequal! var₁ var₂)
102+
(are-inequal! var₁ var₃)
103+
(are-inequal! var₂ var₃)
104+
(solve var₁ var₂ var₃)
105+
(assert-that (value var₁) (is-not- (equal-to (value var₂))))
106+
(assert-that (value var₁) (is-not- (equal-to (value var₃))))
107+
(assert-that (value var₂) (is-not- (equal-to (value var₃))))))

0 commit comments

Comments
 (0)