From 77c7dc4a913a9e08984fb9e259eaf4df8bfe3bba Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Tue, 29 Dec 2015 14:11:36 +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"
+
))