Add initial version of constraint solver

relates #135

src/pyherc/solver.hy

@@ -0,0 +1,122 @@
+;; -*- coding: utf-8 -*-
+;;
+;;   Copyright 2010-2015 Tuukka Turto
+;;
+;;   This file is part of pyherc.
+;;
+;;   pyherc is free software: you can redistribute it and/or modify
+;;   it under the terms of the GNU General Public License as published by
+;;   the Free Software Foundation, either version 3 of the License, or
+;;   (at your option) any later version.
+;;
+;;   pyherc is distributed in the hope that it will be useful,
+;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;   GNU General Public License for more details.
+;;
+;;   You should have received a copy of the GNU General Public License
+;;   along with pyherc.  If not, see <http://www.gnu.org/licenses/>.
+
+(require hy.contrib.anaphoric
+         pyherc.macros)
+
+(defmacro/g! fact [name desc &rest body]
+  `(defun ~name [var1 var2]
+     (let [[~g!func (fn [context updated-variable]
+                      ~desc
+                      (do ~@body))]]
+       (.append var1.constraints ~g!func)
+       (.append var2.constraints ~g!func))))
+
+(defclass Variable []
+  [[--init-- (fn [self &rest values]
+               "default initializer"
+               (setv self.values (set values))
+               (setv self.constraints [])
+               (setv self.last-save-frame-pointer -1)
+               nil)]
+   [--repr-- (fn [self]
+              (str self.values))]])
+
+(defn value [variable]
+  "Get unique value of given variable"
+  (if (unique? variable)
+    (first variable.values)
+    (assert false)))
+
+(defn unique? [variable]
+  "does variable have exactly one value"
+  (= (len variable.values) 1))
+
+(defn value? [variable]
+  "does the variable have a valid value"
+  (len variable.values))
+
+(defn narrow [context variable values]
+  "narrow down variable"
+  (let [[new-values (& variable.values values)]]
+    (if (= new-values (set []))
+      false
+      (if (= new-values variable.values)
+        true
+        (do (.append (:variable-stack context) variable)
+            (.append (:value-stack context) variable.values)
+            (setv variable.last-save-frame-pointer (:frame-pointer context))
+            (setv variable.values new-values)
+            (all (genexpr (constraint context variable)
+                          [constraint variable.constraints])))))))
+
+(defn save [context variable]
+  "save variable state in undo stack"
+  (.append (:variable-stack context) variable)
+  (.append (:value-stack context) variable.values)
+  (setv variable.last-save-frame-pointer (:frame-pointer context)))
+
+(defn restore-values [context variable frame-pointer]
+  "restore variable states from undo stack"
+  (while (> (len (:variable-stack context)) frame-pointer)
+    (let [[var (.pop (:variable-stack context))]
+          [vals (.pop (:value-stack context))]]
+      (setv var.values vals)))
+  (setv (:frame-pointer context) frame-pointer))
+
+(fact are-equal!
+      "equality constraint"
+      (if (= updated-variable var1)
+        (narrow context var2 updated-variable.values)
+        (narrow context var1 updated-variable.values)))
+
+(defn solve [&rest variables]
+  "solve all variables"
+  (let [[context {:frame-pointer nil
+                  :variable-stack []
+                  :value-stack []
+                  :solved false}]]
+    (solve-one context variables)))
+
+(defn solve-one [context variables]
+  "solve all variables"  
+  (if (all (map unique? variables))
+    (do (assoc context :solved true)        
+        variables)
+    (let [[variable (variable-to-solve variables)]
+          [frame (len (:variable-stack context))]]
+      (assoc context :frame-pointer frame)
+      (for [value variable.values]        
+        (do (when (not (:solved context))
+              (if (narrow context variable (set [value]))
+                (do (if (all (map value? variables))
+                      (if (not (solve-one context variables))
+                        (assert false))))
+                false))
+            (when (not (:solved context))
+              (while (!= (len (:variable-stack context)) frame)
+                (let [[var (.pop (:variable-stack context))]
+                      [val (.pop (:value-stack context))]]
+                  (setv var.values val)))
+              (assoc context :frame-pointer frame)))))))
+
+(defn variable-to-solve [variables]
+  "select next variable to solve"
+  (first (filter (fn [x] (not (unique? x)))
+                 variables)))

src/pyherc/test/__init__.py

@@ -38,6 +38,7 @@
 from pyherc.test.unit.test_section import *
 from pyherc.test.unit.test_shoes import *
 from pyherc.test.unit.test_skills import *
+from pyherc.test.unit.test_solver import *
 from pyherc.test.unit.test_surround_decorator import *
 from pyherc.test.unit.test_trapgeneration import *
 from pyherc.test.unit.test_trapping import *

src/pyherc/test/unit/test_solver.hy

@@ -0,0 +1,67 @@
+;; -*- coding: utf-8 -*-
+;;
+;;   Copyright 2010-2015 Tuukka Turto
+;;
+;;   This file is part of pyherc.
+;;
+;;   pyherc is free software: you can redistribute it and/or modify
+;;   it under the terms of the GNU General Public License as published by
+;;   the Free Software Foundation, either version 3 of the License, or
+;;   (at your option) any later version.
+;;
+;;   pyherc is distributed in the hope that it will be useful,
+;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;   GNU General Public License for more details.
+;;
+;;   You should have received a copy of the GNU General Public License
+;;   along with pyherc.  If not, see <http://www.gnu.org/licenses/>.
+
+(import [pyherc.solver [Variable are-equal! solve solve-one value]]
+        [hamcrest [assert-that is- equal-to]])
+
+(defn context []
+  "create an empty context for testing"
+  {:frame-pointer 0
+   :variable-stack []
+   :value-stack []
+   :solved false})
+
+(defn test-simple-equality []
+  "simple equality test"
+  (let [[var₁ (Variable 1 2 3)]
+        [var₂ (Variable 3 4 5)]]    
+    (are-equal! var₁ var₂)
+    (solve var₁ var₂)
+    (assert-that (value var₁) (is- (equal-to (value var₂))))))
+
+(defn test-are-equal []
+  "applying equality will narrow down correctly"
+  (let [[var₁ (Variable 1)]
+        [var₂ (Variable 1 2 3)]]
+    (are-equal! var₁ var₂)
+    ((first var₁.constraints) (context) var₁)
+    (assert-that (value var₁) (is- (equal-to (value var₂))))))
+
+(defn test-not-equal-results-false []
+  "narrow non-equals with equality will return false"
+  (let [[var₁ (Variable 1)]
+        [var₂ (Variable 2 3)]]
+    (are-equal! var₁ var₂)
+    (assert-that ((first var₁.constraints) (context) var₁) (is- (equal-to false)))))
+
+(defn test-easy-narrow []
+  "two variables with same domains and equality constraint are narrowed down"
+  (let [[var₁ (Variable 1 2)]
+        [var₂ (Variable 1 2)]]
+    (are-equal! var₁ var₂)
+    (solve var₁ var₂)
+    (assert-that (value var₁) (is- (equal-to (value var₂))))))
+
+(defn test-single-value-left []
+  "when variables have single value left, they are reported"
+  (let [[var₁ (Variable 1)]
+        [var₂ (Variable 2)]]
+    (solve var₁ var₂)
+    (assert-that (value var₁) (is- (equal-to 1)))
+    (assert-that (value var₂) (is- (equal-to 2)))))