From 63e57753b0ceec20d933225bb39c2dc627fc9bfe Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 29 Dec 2015 14:09:39 +0000 Subject: [PATCH] Further substantial progress made, but it still doesn't completely work. --- src/mw_parser/declarative.clj | 72 ++++++++++++++++++++++------- test/mw_parser/declarative_test.clj | 68 +++++++++++++++++---------- 2 files changed, 98 insertions(+), 42 deletions(-) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index 6d9e1ca..1801b12 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -85,18 +85,19 @@ "From this `tree`, assumed to be a syntactically correct rule specification, generate and return the appropriate rule as a function of two arguments." [tree] - (let [left (generate (nth tree 2)) - right (generate (nth tree 4))] - (list 'fn ['cell 'world] (list 'if left right)))) + (assert-type tree :RULE) + (list 'fn ['cell 'world] (list 'if (generate (nth tree 2)) (generate (nth tree 3))))) (defn generate-conditions "From this `tree`, assumed to be a syntactically correct conditions clause, generate and return the appropriate clojure fragment." [tree] + (assert-type tree :CONDITIONS) (generate (nth tree 1))) (defn generate-condition [tree] + (assert-type tree :CONDITION) (generate (nth tree 1))) (defn generate-conjunct-condition @@ -109,21 +110,40 @@ (assert-type tree :DISJUNCT-CONDITION) (list 'or (generate (nth tree 1))(generate (nth tree 3)))) +(defn generate-ranged-property-condition + "Generate a property condition where the expression is a numeric range" + [tree property expression] + (assert-type tree :PROPERTY-CONDITION) + (assert-type (nth tree 3) :RANGE-EXPRESSION) + (let [l1 (generate (nth expression 2)) + l2 (generate (nth expression 4)) + pv (list property 'cell)] + (list 'let ['lower (list 'min l1 l2) + 'upper (list 'max l1 l2)] + (list 'and (list '>= pv 'lower)(list '<= pv 'upper))))) (defn generate-property-condition - [tree] - (assert-type tree :PROPERTY-CONDITION) - (let [property (generate (nth tree 1)) - qualifier (generate (nth tree 2)) - expression (generate (nth tree 3))] - (list qualifier (list property 'cell) expression))) + ([tree] + (assert-type tree :PROPERTY-CONDITION) + (generate-property-condition tree (first (nth tree 3)))) + ([tree expression-type] + (assert-type tree :PROPERTY-CONDITION) + (let [property (generate (nth tree 1)) + qualifier (generate (nth tree 2)) + expression (generate (nth tree 3))] + (case expression-type + :DISJUNCT-EXPRESSION (list 'let ['value (list property 'cell)] (list 'some (list 'fn ['i] '(= i value)) (list 'quote expression))) + :RANGE-EXPRESSION (generate-ranged-property-condition tree property expression) + (list qualifier (list property 'cell) expression))))) (defn generate-simple-action [tree] (assert-type tree :SIMPLE-ACTION) (let [property (generate (nth tree 1)) expression (generate (nth tree 3))] - (list 'merge 'cell {property expression}))) + (if (or (= property :x) (= property :y)) + (throw (Exception. reserved-properties-error)) + (list 'merge 'cell {property expression})))) (defn generate-multiple-actions [tree] @@ -131,6 +151,22 @@ ;; (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") ;; (conj 'do (map +(defn generate-disjunct-value + "Generate a disjunct value. Essentially what we need here is to generate a + flat list of values, since the `member` has already been taken care of." + [tree] + (assert-type tree :DISJUNCT-VALUE) + (if (= (count tree) 4) + (cons (generate (second tree)) (generate (nth tree 3))) + (list (generate (second tree))))) + +(defn generate-numeric-expression + [tree] + (assert-type tree :NUMERIC-EXPRESSION) + (case (first (second tree)) + :SYMBOL (list (keyword (second (second tree))) 'cell) + (generate (second tree)))) + (defn generate "Generate code for this (fragment of a) parse tree" [tree] @@ -144,6 +180,9 @@ :DISJUNCT-CONDITION (generate-disjunct-condition tree) :CONJUNCT-CONDITION (generate-conjunct-condition tree) :PROPERTY-CONDITION (generate-property-condition tree) + :DISJUNCT-EXPRESSION (generate (nth tree 2)) + :NUMERIC-EXPRESSION (generate-numeric-expression tree) + :DISJUNCT-VALUE (generate-disjunct-value tree) :SIMPLE-ACTION (generate-simple-action tree) :ACTIONS (generate-multiple-actions tree) :SYMBOL (keyword (second tree)) @@ -209,11 +248,9 @@ (insta/parser grammar)) (defn explain-parse-error-reason - "The parse error `reason` is a complex structure of which I have as yet seen - few examples. This function is a place-holder so that I can later produce - friendlier reason messages." + "Attempt to explain the reason for the parse error." [reason] - reason) + (str "Expecting one of (" (apply str (map #(str (:expecting %) " ") (first reason))) ")")) (defn throw-parse-exception "Construct a helpful error message from this `parser-error`, and throw an exception with that message." @@ -230,16 +267,17 @@ column (if (:column error-map)(first (:column error-map)) 0) ;; create a cursor to point to that column cursor (apply str (reverse (conj (repeat column " ") "^"))) + message (format bad-parse-error text cursor reason) ] - (throw (Exception. (format bad-parse-error text cursor reason))))) + (throw (Exception. message)))) (defn compile-rule "Compile this `rule`, assumed to be a string with appropriate syntax, into a function of two arguments, a `cell` and a `world`, having the same semantics." [rule] (assert (string? rule)) - (let [tree (parse-rule rule)] - (if (rule? rule) (generate (simplify tree)) + (let [tree (simplify (parse-rule rule))] + (if (rule? rule) (generate tree) (throw-parse-exception tree)))) diff --git a/test/mw_parser/declarative_test.clj b/test/mw_parser/declarative_test.clj index ab6b04f..67b31d1 100644 --- a/test/mw_parser/declarative_test.clj +++ b/test/mw_parser/declarative_test.clj @@ -31,53 +31,71 @@ (is (rule? (parse-rule "if 6 neighbours have state equal to water then state should be village"))) )) +(deftest expressions-tests + (testing "Generating primitive expressions." + (is (generate '(:NUMERIC-EXPRESSION (:NUMBER "50"))) 50) + (is (generate '(:NUMERIC-EXPRESSION (:SYMBOL "sealevel"))) + '(:sealevel cell)) + )) + (deftest lhs-generators-tests (testing "Generating left-hand-side fragments of rule functions from appropriate fragments of parse trees" - (is (generate-property-condition + (is (generate '(:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest"))) '(= (:state cell) :forest)) - (is (generate-property-condition + (is (generate '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:EQUIVALENCE [:IS "is"]] (:NUMBER "10"))) '(= (:fertility cell) 10)) - (is (generate-property-condition '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:COMPARATIVE [:LESS "less"]] (:NUMBER "10"))) + (is (generate '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:COMPARATIVE [:LESS "less"]] (:NUMBER "10"))) '(< (:fertility cell) 10)) - (is (generate-property-condition '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:COMPARATIVE [:MORE "more"]] (:NUMBER "10"))) + (is (generate '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:COMPARATIVE [:MORE "more"]] (:NUMBER "10"))) '(> (:fertility cell) 10)) - (is (generate-conjunct-condition '(:CONJUNCT-CONDITION (:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest")) (:AND "and") (:PROPERTY-CONDITION (:SYMBOL "fertility") [:EQUIVALENCE [:IS "is"]] (:NUMBER "10")))) + (is (generate '(:CONJUNCT-CONDITION (:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest")) (:AND "and") (:PROPERTY-CONDITION (:SYMBOL "fertility") [:EQUIVALENCE [:IS "is"]] (:NUMBER "10")))) '(and (= (:state cell) :forest) (= (:fertility cell) 10))) - (is (generate-disjunct-condition '(:DISJUNCT-CONDITION (:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest")) (:OR "or") (:PROPERTY-CONDITION (:SYMBOL "fertility") [:EQUIVALENCE [:IS "is"]] (:NUMBER "10")))) + (is (generate '(:DISJUNCT-CONDITION (:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest")) (:OR "or") (:PROPERTY-CONDITION (:SYMBOL "fertility") [:EQUIVALENCE [:IS "is"]] (:NUMBER "10")))) '(or (= (:state cell) :forest) (= (:fertility cell) 10))) + (is (generate '(:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:DISJUNCT-EXPRESSION (:IN "in") (:DISJUNCT-VALUE (:SYMBOL "grassland") (:OR "or") (:DISJUNCT-VALUE (:SYMBOL "pasture") (:OR "or") (:DISJUNCT-VALUE (:SYMBOL "heath"))))))) + '(let [value (:state cell)] (some (fn [i] (= i value)) (quote (:grassland :pasture :heath))))) + (is (generate '(:PROPERTY-CONDITION (:SYMBOL "altitude") [:EQUIVALENCE [:IS "is"]] (:RANGE-EXPRESSION (:BETWEEN "between") (:NUMERIC-EXPRESSION (:NUMBER "50")) (:AND "and") (:NUMERIC-EXPRESSION (:NUMBER "100"))))) + '(let [lower (min 50 100) upper (max 50 100)] (and (>= (:altitude cell) lower) (<= (:altitude cell) upper)))) )) (deftest rhs-generators-tests - (testing "Generating left-hand-side fragments of rule functions from appropriate fragments of parse trees" - (is (generate-simple-action + (testing "Generating right-hand-side fragments of rule functions from appropriate fragments of parse trees" + (is (generate '(:SIMPLE-ACTION (:SYMBOL "state") (:BECOMES "should be") (:SYMBOL "climax"))) '(merge cell {:state :climax})) - (is (generate-simple-action + (is (generate '(:SIMPLE-ACTION (:SYMBOL "fertility") (:BECOMES "should be") (:NUMBER "10"))) '(merge cell {:fertility 10})) )) +(deftest full-generation-tests + (testing "Full rule generation from pre-parsed tree" + (is (generate '(:RULE (:IF "if") (:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest")) (:SIMPLE-ACTION (:SYMBOL "state") (:BECOMES "should be") (:SYMBOL "climax")))) + '(fn [cell world] (if (= (:state cell) :forest) (merge cell {:state :climax})))) + )) + + (deftest exception-tests (testing "Constructions which should cause exceptions to be thrown" (is (thrown-with-msg? Exception #"^I did not understand.*" (compile-rule "the quick brown fox jumped over the lazy dog")) "Exception thrown if rule text does not match grammar") -;; (is (thrown-with-msg? -;; Exception #"The properties 'x' and 'y' of a cell are reserved and should not be set in rule actions" -;; (compile-rule "if state is new then x should be 0")) -;; "Exception thrown on attempt to set 'x'") -;; (is (thrown-with-msg? -;; Exception #"The properties 'x' and 'y' of a cell are reserved and should not be set in rule actions" -;; (compile-rule "if state is new then y should be 0")) -;; "Exception thrown on attempt to set 'y'") -;; (is (thrown? Exception (compile-rule "if state is new then x should be 0")) -;; "Can't set x property to number, as this would break the world") -;; (is (thrown? Exception (compile-rule "if state is new then y should be 0")) -;; "Can't set y property to number, as this would break the world") -;; (is (thrown? Exception (compile-rule "if state is new then x should be heath")) -;; "Can't set x property to symbol, as this would break the world") -;; (is (thrown? Exception (compile-rule "if state is new then y should be heath")) -;; "Can't set y property to symbol, as this would break the world") + (is (thrown-with-msg? Exception #"^I did not understand.*" + (compile-rule "if i have a cat on my lap then everything is fine")) + "Exception thrown if rule text does not match grammar") + (is (thrown-with-msg? + Exception #"The properties 'x' and 'y' of a cell are reserved and should not be set in rule actions" + (compile-rule "if state is new then x should be 0")) + "Exception thrown on attempt to set 'x'") + (is (thrown-with-msg? + Exception #"The properties 'x' and 'y' of a cell are reserved and should not be set in rule actions" + (compile-rule "if state is new then y should be 0")) + "Exception thrown on attempt to set 'y'") + )) + +(deftest compilation-tests + (testing "Full compilation of rules" + ))