Further substantial progress made, but it still doesn't completely work.

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))
+  (assert-type tree :RULE)
-        right (generate (nth tree 4))]
+  (list 'fn ['cell 'world] (list 'if (generate (nth tree 2)) (generate (nth tree 3)))))
-    (list 'fn ['cell 'world] (list 'if left right))))
 
 (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]
+  ([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))]
-    (list qualifier (list property 'cell) expression)))
+     (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
+  "Attempt to explain the reason for the parse error."
-   few examples. This function is a place-holder so that I can later produce
-   friendlier reason messages."
   [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)]
+  (let [tree (simplify (parse-rule rule))]
-    (if (rule? rule) (generate (simplify tree))
+    (if (rule? rule) (generate tree)
       (throw-parse-exception tree))))
 
 

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"
+  (testing "Generating right-hand-side fragments of rule functions from appropriate fragments of parse trees"
-    (is (generate-simple-action
+    (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?
+    (is (thrown-with-msg? Exception #"^I did not understand.*"
-;;          Exception #"The properties 'x' and 'y' of a cell are reserved and should not be set in rule actions"
+                          (compile-rule "if i have a cat on my lap then everything is fine"))
-;;          (compile-rule "if state is new then x should be 0"))
+        "Exception thrown if rule text does not match grammar")
-;;         "Exception thrown on attempt to set 'x'")
+     (is (thrown-with-msg?
-;;     (is (thrown-with-msg?
+          Exception #"The properties 'x' and 'y' of a cell are reserved and should not be set in rule actions"
-;;          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"))
-;;          (compile-rule "if state is new then y should be 0"))
+         "Exception thrown on attempt to set 'x'")
-;;         "Exception thrown on attempt to set 'y'")
+     (is (thrown-with-msg?
-;;     (is (thrown? Exception (compile-rule "if state is new then x should be 0"))
+          Exception #"The properties 'x' and 'y' of a cell are reserved and should not be set in rule actions"
-;;         "Can't set x property to number, as this would break the world")
+          (compile-rule "if state is new then y should be 0"))
-;;     (is (thrown? Exception (compile-rule "if state is new then y should be 0"))
+         "Exception thrown on attempt to set 'y'")
-;;         "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")
+(deftest compilation-tests
-;;     (is (thrown? Exception (compile-rule "if state is new then y should be heath"))
+  (testing "Full compilation of rules"
-;;         "Can't set y property to symbol, as this would break the world")
+
     ))