From 20de9e45280a32bd393c25ef4649607d3fbb644d Mon Sep 17 00:00:00 2001 From: Tuukka Turto Date: Thu, 29 Oct 2015 23:10:33 +0200 Subject: [PATCH] Add initial version of constraint solver relates #135 --- src/pyherc/solver.hy | 122 ++++++++++++++++++++++++++++ src/pyherc/test/__init__.py | 1 + src/pyherc/test/unit/test_solver.hy | 67 +++++++++++++++ 3 files changed, 190 insertions(+) create mode 100644 src/pyherc/solver.hy create mode 100644 src/pyherc/test/unit/test_solver.hy diff --git a/src/pyherc/solver.hy b/src/pyherc/solver.hy new file mode 100644 index 00000000..e80b7ec3 --- /dev/null +++ b/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 . + +(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))) diff --git a/src/pyherc/test/__init__.py b/src/pyherc/test/__init__.py index f71c633d..b76a55a7 100644 --- a/src/pyherc/test/__init__.py +++ b/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 * diff --git a/src/pyherc/test/unit/test_solver.hy b/src/pyherc/test/unit/test_solver.hy new file mode 100644 index 00000000..aada4bba --- /dev/null +++ b/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 . + +(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)))))