From 40631e530f97992a90c8905f227678e614b053ad Mon Sep 17 00:00:00 2001 From: simon Date: Sat, 30 Aug 2014 14:52:56 +0100 Subject: [PATCH 01/23] Upversioned from 0.1.3 to 0.1.3-SNAPSHOT --- project.clj | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/project.clj b/project.clj index 66d845e..1b2221b 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject mw-parser "0.1.3" +(defproject mw-parser "0.1.3-SNAPSHOT" :description "Parser for production rules for MicroWorld engine" :url "http://www.journeyman.cc/microworld" :manifest { @@ -13,5 +13,5 @@ :plugins [[lein-marginalia "0.7.1"]] :dependencies [[org.clojure/clojure "1.5.1"] [org.clojure/tools.trace "0.7.8"] - [mw-engine "0.1.3"] + [mw-engine "0.1.3-SNAPSHOT"] ]) From c31dd91185cb467f59ba08eed6deca405d0b8845 Mon Sep 17 00:00:00 2001 From: simon Date: Sat, 30 Aug 2014 14:59:26 +0100 Subject: [PATCH 02/23] Upversioned from 0.1.3-SNAPSHOT to 0.1.3 for release --- project.clj | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/project.clj b/project.clj index 1b2221b..66d845e 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject mw-parser "0.1.3-SNAPSHOT" +(defproject mw-parser "0.1.3" :description "Parser for production rules for MicroWorld engine" :url "http://www.journeyman.cc/microworld" :manifest { @@ -13,5 +13,5 @@ :plugins [[lein-marginalia "0.7.1"]] :dependencies [[org.clojure/clojure "1.5.1"] [org.clojure/tools.trace "0.7.8"] - [mw-engine "0.1.3-SNAPSHOT"] + [mw-engine "0.1.3"] ]) From 84a187796b7e9f6ab4c7965c1b69a1a6fe8b9eb6 Mon Sep 17 00:00:00 2001 From: simon Date: Sat, 30 Aug 2014 14:59:52 +0100 Subject: [PATCH 03/23] Upversioned from 0.1.3 to 0.1.4-SNAPSHOT --- project.clj | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/project.clj b/project.clj index 66d845e..9179781 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject mw-parser "0.1.3" +(defproject mw-parser "0.1.4-SNAPSHOT" :description "Parser for production rules for MicroWorld engine" :url "http://www.journeyman.cc/microworld" :manifest { @@ -13,5 +13,5 @@ :plugins [[lein-marginalia "0.7.1"]] :dependencies [[org.clojure/clojure "1.5.1"] [org.clojure/tools.trace "0.7.8"] - [mw-engine "0.1.3"] + [mw-engine "0.1.4-SNAPSHOT"] ]) From d93d56dfabedb1761e99e657dd96a065da66ee9b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 7 Sep 2014 20:15:24 +0100 Subject: [PATCH 04/23] Changed memory size (?) --- project.clj | 1 + 1 file changed, 1 insertion(+) diff --git a/project.clj b/project.clj index 1b2221b..1a7e4a1 100644 --- a/project.clj +++ b/project.clj @@ -13,5 +13,6 @@ :plugins [[lein-marginalia "0.7.1"]] :dependencies [[org.clojure/clojure "1.5.1"] [org.clojure/tools.trace "0.7.8"] + [instaparse "1.3.3"] [mw-engine "0.1.3-SNAPSHOT"] ]) From 79b8e11df8e8bebaaf038c850abe44054881ad6f Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 15 Oct 2014 22:18:47 +0100 Subject: [PATCH 05/23] Upversioned from 0.1.4-SNAPSHOT to 0.1.4 for release --- project.clj | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/project.clj b/project.clj index 9179781..30a782f 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject mw-parser "0.1.4-SNAPSHOT" +(defproject mw-parser "0.1.4" :description "Parser for production rules for MicroWorld engine" :url "http://www.journeyman.cc/microworld" :manifest { @@ -13,5 +13,5 @@ :plugins [[lein-marginalia "0.7.1"]] :dependencies [[org.clojure/clojure "1.5.1"] [org.clojure/tools.trace "0.7.8"] - [mw-engine "0.1.4-SNAPSHOT"] + [mw-engine "0.1.4"] ]) From dddeea60418e58e2f5ce2ee43686566a1bbb2b3b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 15 Oct 2014 22:19:08 +0100 Subject: [PATCH 06/23] Upversioned from 0.1.4 to 0.1.5-SNAPSHOT --- project.clj | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/project.clj b/project.clj index 30a782f..4fb0b2a 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject mw-parser "0.1.4" +(defproject mw-parser "0.1.5-SNAPSHOT" :description "Parser for production rules for MicroWorld engine" :url "http://www.journeyman.cc/microworld" :manifest { @@ -13,5 +13,5 @@ :plugins [[lein-marginalia "0.7.1"]] :dependencies [[org.clojure/clojure "1.5.1"] [org.clojure/tools.trace "0.7.8"] - [mw-engine "0.1.4"] + [mw-engine "0.1.5-SNAPSHOT"] ]) From 2e7eefc748bde369e30f3e37046ab641845f76cb Mon Sep 17 00:00:00 2001 From: simon Date: Mon, 20 Oct 2014 17:25:56 +0100 Subject: [PATCH 07/23] Using Clojure 1.6 --- project.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project.clj b/project.clj index 4fb0b2a..b3e5429 100644 --- a/project.clj +++ b/project.clj @@ -11,7 +11,7 @@ :license {:name "GNU General Public License v2" :url "http://www.gnu.org/licenses/gpl-2.0.html"} :plugins [[lein-marginalia "0.7.1"]] - :dependencies [[org.clojure/clojure "1.5.1"] + :dependencies [[org.clojure/clojure "1.6.0"] [org.clojure/tools.trace "0.7.8"] [mw-engine "0.1.5-SNAPSHOT"] ]) From bbac9a9c6e88b098c120f4c9d6798ae0ef3d23df Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 10 Feb 2015 22:26:53 +0000 Subject: [PATCH 08/23] New work on the parser, based on instaparse. --- project.clj | 1 + src/mw_parser/insta.clj | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+) create mode 100644 src/mw_parser/insta.clj diff --git a/project.clj b/project.clj index 4fb0b2a..9615663 100644 --- a/project.clj +++ b/project.clj @@ -13,5 +13,6 @@ :plugins [[lein-marginalia "0.7.1"]] :dependencies [[org.clojure/clojure "1.5.1"] [org.clojure/tools.trace "0.7.8"] + [instaparse "1.3.5"] [mw-engine "0.1.5-SNAPSHOT"] ]) diff --git a/src/mw_parser/insta.clj b/src/mw_parser/insta.clj new file mode 100644 index 0000000..f663861 --- /dev/null +++ b/src/mw_parser/insta.clj @@ -0,0 +1,32 @@ +(ns mw-parser.insta + (:use mw-engine.utils + [clojure.string :only [split trim triml]]) + (:require [instaparse.core :as insta])) + + +(def grammar + "RULE := 'if' SPACE CONDITIONS SPACE 'then' SPACE ACTIONS; + CONDITIONS := CONDITION | CONDITION SPACE 'and' SPACE CONDITIONS; + CONDITION := DISJUNCT-CONDITION | PROPERTY-CONDITION; + DISJUNCT-CONDITION := CONDITION SPACE 'or' SPACE CONDITION; + PROPERTY-CONDITION := PROPERTY SPACE 'is' SPACE EXPRESSION; + EXPRESSION := VALUE QUALIFIER EXPRESSION | VALUE OPERATOR EXPRESSION | VALUE; + QUALIFIER := SPACE 'more' SPACE 'than' SPACE | SPACE 'less' SPACE 'than' SPACE | SPACE 'fewer' SPACE 'than' SPACE | SPACE 'equal' SPACE 'to' SPACE ; + OPERATOR := '+' | '-' | '*' | '/'; + PROPERTY := SYMBOL; + VALUE := SYMBOL | NUMBER; + NUMBER := #'[0-9.]+'; + SYMBOL := #'[a-z]+'; + ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS + ACTION := SYMBOL SPACE 'should' SPACE 'be' SPACE EXPRESSION + SPACE := #'[:blank:]*'" + ) + +(def rule-parser + (insta/parser grammar)) + +(def token-parser (insta/parser "TOKEN := #'[a-z]+'")) + + + + \ No newline at end of file From 52a4f6231094e0ae5cd31e890528e9f347834da0 Mon Sep 17 00:00:00 2001 From: simon Date: Thu, 12 Feb 2015 08:11:50 +0000 Subject: [PATCH 09/23] New parser now well advanced, parses all but one of the test rules. However code generation only just started. --- src/mw_parser/insta.clj | 142 ++++++++++++++++++++++++++++++++++++---- 1 file changed, 129 insertions(+), 13 deletions(-) diff --git a/src/mw_parser/insta.clj b/src/mw_parser/insta.clj index f663861..0dccaaf 100644 --- a/src/mw_parser/insta.clj +++ b/src/mw_parser/insta.clj @@ -4,29 +4,145 @@ (:require [instaparse.core :as insta])) -(def grammar +(def grammar "RULE := 'if' SPACE CONDITIONS SPACE 'then' SPACE ACTIONS; - CONDITIONS := CONDITION | CONDITION SPACE 'and' SPACE CONDITIONS; - CONDITION := DISJUNCT-CONDITION | PROPERTY-CONDITION; - DISJUNCT-CONDITION := CONDITION SPACE 'or' SPACE CONDITION; - PROPERTY-CONDITION := PROPERTY SPACE 'is' SPACE EXPRESSION; - EXPRESSION := VALUE QUALIFIER EXPRESSION | VALUE OPERATOR EXPRESSION | VALUE; - QUALIFIER := SPACE 'more' SPACE 'than' SPACE | SPACE 'less' SPACE 'than' SPACE | SPACE 'fewer' SPACE 'than' SPACE | SPACE 'equal' SPACE 'to' SPACE ; + CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | PROPERTY-CONDITION | NEIGHBOURS-CONDITION ; + DISJUNCT-CONDITION := CONDITION SPACE 'or' SPACE CONDITIONS; + CONJUNCT-CONDITION := CONDITION SPACE 'and' SPACE CONDITIONS; + CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; + NEIGHBOURS-CONDITION := QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; + PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION; + EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; + SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; + DISJUNCT-EXPRESSION := 'in' SPACE DISJUNCT-VALUE; + RANGE-EXPRESSION := 'between' SPACE NUMERIC-EXPRESSION SPACE 'and' SPACE NUMERIC-EXPRESSION; + NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION; + QUALIFIER := COMPARATIVE SPACE 'than' | EQUIVALENCE | IS SPACE QUALIFIER; + NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors'; + QUANTIFIER := NUMBER | 'some' | 'no' | 'all'; + EQUIVALENCE := IS SPACE 'equal to' | 'equal to' | IS ; + COMPARATIVE := 'more' | 'less' | 'fewer'; OPERATOR := '+' | '-' | '*' | '/'; PROPERTY := SYMBOL; + DISJUNCT-VALUE := VALUE | VALUE SPACE 'or' SPACE DISJUNCT-VALUE; VALUE := SYMBOL | NUMBER; - NUMBER := #'[0-9.]+'; + IS := 'is' | 'are' | 'have'; + NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+'; SYMBOL := #'[a-z]+'; ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS - ACTION := SYMBOL SPACE 'should' SPACE 'be' SPACE EXPRESSION - SPACE := #'[:blank:]*'" + ACTION := SIMPLE-ACTION | PROBABLE-ACTION; + PROBABLE-ACTION := VALUE SPACE 'chance in' SPACE VALUE SPACE SIMPLE-ACTION; + SIMPLE-ACTION := SYMBOL SPACE 'should be' SPACE EXPRESSION + SPACE := #' *'" ) +(defn TODO + "Marker to indicate I'm not yet finished!" + [message] + message) + + +(declare generate) + +(defn generate-rule + "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)))) + +(defn generate-conditions + "From this `tree`, assumed to be a syntactically correct conditions clause, + generate and return the appropriate clojure fragment." + [tree] + (generate (nth tree 1))) + +(defn generate-condition + [tree] + (generate (nth tree 1))) + +(defn generate-conjunct-condition + [tree] + (list 'and (generate (nth tree 1))(generate (nth tree 3)))) + +(defn generate-disjunct-condition + [tree] + (list 'or (generate (nth tree 1))(generate (nth tree 3)))) + +(defn generate-qualifier + "Return more than (>), less than (<) or equal to (=) depending on the `qualifier`." + [qualifier] + (TODO "not written yet") + tree) + + +(defn generate-property-condition + [tree] + (let [property (generate (nth tree 1)) + qualifier (generate (nth tree 2)) + expression (generate (nth tree 3))] + (list qualifier (list (keyword property) 'cell) expression))) + + +(defn generate + "Generate code for this (fragment of a) parse tree" + [tree] + (case (first tree) + :RULE (generate-rule tree) + :CONDITIONS (generate-conditions tree) + :CONDITION (generate-condition tree) +;; :NEIGHBOURS-CONDITION (generate-neighbours-condition tree) + :DISJUNCT-CONDITION (generate-disjunct-condition tree) + :CONJUNCT-CONDITION (generate-conjunct-condition tree) + :PROPERTY-CONDITION (generate-property-condition tree) +;; :EXPRESSION (generate-expression tree) +;; :SIMPLE-EXPRESSION + tree)) + +(defn prune-tree + "Simplify/canonicalise the `tree`. Opportunistically replace complex fragments with + semantically identical simpler fragments" + [tree] + (TODO "not written yet") + tree) + +(defn clean-tree + "Returns a structure which is structurally equivalent to `tree` but which has + the noise tokens (spaces) removed. As a side effect this new structure is a + list, not a vector, but that is not a desideratum and you should not rely in it." + [tree] + (cond + (and (coll? tree) (= (first tree) :SPACE)) nil + (coll? tree) (remove nil? (map clean-tree tree)) + true tree)) + (def rule-parser (insta/parser grammar)) -(def token-parser (insta/parser "TOKEN := #'[a-z]+'")) +(defn compile-rule [rule] + (generate (prune-tree (clean-tree (rule-parser rule))))) - - \ No newline at end of file + + +(compile-rule "if state is climax and some neighbours have state equal to fire then 3 chance in 5 state should be fire") + + +(rule-parser "if state is in grassland or pasture or heath and 4 neighbours have state equal to water then state should be village") + +(rule-parser "if 6 neighbours have state equal to water then state should be village") + +(rule-parser "if fertility is between 55 and 75 then state should be climax") + +(rule-parser "if state is forest then state should be climax") + + +(rule-parser "if state is in grassland or pasture or heath and 4 neighbours have state equal to water then state should be village") +(rule-parser "if altitude is less than 100 and state is forest then state should be climax and deer should be 3") +(rule-parser "if altitude is 100 or fertility is 25 then state should be heath and fertility should be 24.3") +(rule-parser "if altitude is 100 or fertility is 25 then state should be heath") + +(rule-parser "if deer is more than 2 and wolves is 0 and fertility is more than 20 then deer should be deer + 2") +(rule-parser "if deer is more than 1 and wolves is more than 1 then deer should be deer - wolves") +(rule-parser "if state is grassland and 4 neighbours have state equal to water then state should be village") From 6166dc254c5f316e948c9f574384c8222c944bec Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Fri, 13 Feb 2015 22:25:53 +0000 Subject: [PATCH 10/23] Now almost to the point that the new parser can compile simple rules! --- src/mw_parser/insta.clj | 166 ++++++++++++++++++++++++++-------------- 1 file changed, 108 insertions(+), 58 deletions(-) diff --git a/src/mw_parser/insta.clj b/src/mw_parser/insta.clj index 0dccaaf..9d220f9 100644 --- a/src/mw_parser/insta.clj +++ b/src/mw_parser/insta.clj @@ -5,28 +5,43 @@ (def grammar - "RULE := 'if' SPACE CONDITIONS SPACE 'then' SPACE ACTIONS; + ;; in order to simplify translation into other natural languages, all + ;; TOKENS within the parser should be unambiguous + "RULE := IF SPACE CONDITIONS SPACE THEN SPACE ACTIONS; CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | PROPERTY-CONDITION | NEIGHBOURS-CONDITION ; - DISJUNCT-CONDITION := CONDITION SPACE 'or' SPACE CONDITIONS; - CONJUNCT-CONDITION := CONDITION SPACE 'and' SPACE CONDITIONS; + DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS; + CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS; CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; NEIGHBOURS-CONDITION := QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION; EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; - DISJUNCT-EXPRESSION := 'in' SPACE DISJUNCT-VALUE; - RANGE-EXPRESSION := 'between' SPACE NUMERIC-EXPRESSION SPACE 'and' SPACE NUMERIC-EXPRESSION; + DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE; + RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION; NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION; - QUALIFIER := COMPARATIVE SPACE 'than' | EQUIVALENCE | IS SPACE QUALIFIER; - NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors'; - QUANTIFIER := NUMBER | 'some' | 'no' | 'all'; - EQUIVALENCE := IS SPACE 'equal to' | 'equal to' | IS ; - COMPARATIVE := 'more' | 'less' | 'fewer'; + QUALIFIER := COMPARATIVE SPACE THAN | EQUIVALENCE | IS SPACE QUALIFIER; + QUANTIFIER := NUMBER | SOME | NONE | ALL; + EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; + COMPARATIVE := MORE | LESS; + DISJUNCT-VALUE := VALUE | VALUE SPACE OR SPACE DISJUNCT-VALUE; + IF := 'if'; + THEN := 'then'; + THAN := 'than'; + OR := 'or'; + AND := 'and'; + SOME := 'some'; + NONE := 'no'; + ALL := 'all' + BETWEEN := 'between'; + IN := 'in'; + MORE := 'more'; + LESS := 'less' | 'fewer'; OPERATOR := '+' | '-' | '*' | '/'; + NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors'; PROPERTY := SYMBOL; - DISJUNCT-VALUE := VALUE | VALUE SPACE 'or' SPACE DISJUNCT-VALUE; VALUE := SYMBOL | NUMBER; - IS := 'is' | 'are' | 'have'; + EQUAL := 'equal to'; + IS := 'is' | 'are' | 'have' | 'has'; NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+'; SYMBOL := #'[a-z]+'; ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS @@ -42,7 +57,7 @@ message) -(declare generate) +(declare generate simplify) (defn generate-rule "From this `tree`, assumed to be a syntactically correct rule specification, @@ -70,58 +85,93 @@ [tree] (list 'or (generate (nth tree 1))(generate (nth tree 3)))) -(defn generate-qualifier - "Return more than (>), less than (<) or equal to (=) depending on the `qualifier`." - [qualifier] - (TODO "not written yet") - tree) - (defn generate-property-condition [tree] (let [property (generate (nth tree 1)) qualifier (generate (nth tree 2)) expression (generate (nth tree 3))] - (list qualifier (list (keyword property) 'cell) expression))) + (list qualifier (list property 'cell) expression))) +(defn generate-simple-action + [tree] + (let [property (generate (nth tree 1)) + expression (generate (nth tree 3))] + (list 'merge 'cell {property expression}))) (defn generate "Generate code for this (fragment of a) parse tree" [tree] - (case (first tree) - :RULE (generate-rule tree) - :CONDITIONS (generate-conditions tree) - :CONDITION (generate-condition tree) -;; :NEIGHBOURS-CONDITION (generate-neighbours-condition tree) - :DISJUNCT-CONDITION (generate-disjunct-condition tree) - :CONJUNCT-CONDITION (generate-conjunct-condition tree) - :PROPERTY-CONDITION (generate-property-condition tree) -;; :EXPRESSION (generate-expression tree) -;; :SIMPLE-EXPRESSION + (if + (coll? tree) + (case (first tree) + :RULE (generate-rule tree) + :CONDITIONS (generate-conditions tree) + :CONDITION (generate-condition tree) + ;; :NEIGHBOURS-CONDITION (generate-neighbours-condition tree) + :DISJUNCT-CONDITION (generate-disjunct-condition tree) + :CONJUNCT-CONDITION (generate-conjunct-condition tree) + :PROPERTY-CONDITION (generate-property-condition tree) + :SIMPLE-ACTION (generate-simple-action tree) + :SYMBOL (keyword (second tree)) + :NUMBER (read-string (second tree)) + :EQUIVALENCE '= + :MORE '> + :LESS '< + ;; :EXPRESSION (generate-expression tree) + ;; :SIMPLE-EXPRESSION + (map generate tree)) tree)) -(defn prune-tree - "Simplify/canonicalise the `tree`. Opportunistically replace complex fragments with + +(defn simplify-qualifier + "Given that this `tree` fragment represents a qualifier, what + qualifier is that?" + [tree] + (cond + (empty? tree) nil + (and (coll? tree) + (member? (first tree) '(:EQUIVALENCE :COMPARATIVE))) tree + (coll? (first tree)) (or (simplify-qualifier (first tree)) + (simplify-qualifier (rest tree))) + (coll? tree) (simplify-qualifier (rest tree)) + true tree)) + +(defn simplify-second-of-two + "There are a number of possible simplifications such that if the `tree` has + only two elements, the second is semantically sufficient." + [tree] + (if (= (count tree) 2) (simplify (nth tree 1)) tree)) + + +(defn simplify + "Simplify/canonicalise this `tree`. Opportunistically replace complex fragments with semantically identical simpler fragments" [tree] - (TODO "not written yet") - tree) + (if + (coll? tree) + (case (first tree) + :SPACE nil + :QUALIFIER (simplify-qualifier tree) + :CONDITIONS (simplify-second-of-two tree) + :CONDITION (simplify-second-of-two tree) + :EXPRESSION (simplify-second-of-two tree) + :COMPARATIVE (simplify-second-of-two tree) + :QUANTIFIER (simplify-second-of-two tree) + :VALUE (simplify-second-of-two tree) + :PROPERTY (simplify-second-of-two tree) + :ACTIONS (simplify-second-of-two tree) + :ACTION (simplify-second-of-two tree) + (remove nil? (map simplify tree))) + tree)) -(defn clean-tree - "Returns a structure which is structurally equivalent to `tree` but which has - the noise tokens (spaces) removed. As a side effect this new structure is a - list, not a vector, but that is not a desideratum and you should not rely in it." - [tree] - (cond - (and (coll? tree) (= (first tree) :SPACE)) nil - (coll? tree) (remove nil? (map clean-tree tree)) - true tree)) - -(def rule-parser +(def parse-rule (insta/parser grammar)) -(defn compile-rule [rule] - (generate (prune-tree (clean-tree (rule-parser rule))))) +(defn compile-rule + [rule] + nil) +;; (generate (prune-tree (parse-rule rule)))) @@ -129,20 +179,20 @@ (compile-rule "if state is climax and some neighbours have state equal to fire then 3 chance in 5 state should be fire") -(rule-parser "if state is in grassland or pasture or heath and 4 neighbours have state equal to water then state should be village") +(compile-rule "if state is in grassland or pasture or heath and 4 neighbours have state equal to water then state should be village") -(rule-parser "if 6 neighbours have state equal to water then state should be village") +(compile-rule "if 6 neighbours have state equal to water then state should be village") -(rule-parser "if fertility is between 55 and 75 then state should be climax") +(compile-rule "if fertility is between 55 and 75 then state should be climax") -(rule-parser "if state is forest then state should be climax") +(compile-rule "if state is forest then state should be climax") -(rule-parser "if state is in grassland or pasture or heath and 4 neighbours have state equal to water then state should be village") -(rule-parser "if altitude is less than 100 and state is forest then state should be climax and deer should be 3") -(rule-parser "if altitude is 100 or fertility is 25 then state should be heath and fertility should be 24.3") -(rule-parser "if altitude is 100 or fertility is 25 then state should be heath") +(compile-rule "if state is in grassland or pasture or heath and 4 neighbours have state equal to water then state should be village") +(compile-rule "if altitude is less than 100 and state is forest then state should be climax and deer should be 3") +(compile-rule "if altitude is 100 or fertility is 25 then state should be heath and fertility should be 24.3") +(compile-rule "if altitude is 100 or fertility is 25 then state should be heath") -(rule-parser "if deer is more than 2 and wolves is 0 and fertility is more than 20 then deer should be deer + 2") -(rule-parser "if deer is more than 1 and wolves is more than 1 then deer should be deer - wolves") -(rule-parser "if state is grassland and 4 neighbours have state equal to water then state should be village") +(compile-rule "if deer is more than 2 and wolves is 0 and fertility is more than 20 then deer should be deer + 2") +(compile-rule "if deer is more than 1 and wolves is more than 1 then deer should be deer - wolves") +(compile-rule "if state is grassland and 4 neighbours have state equal to water then state should be village") From 6c1ecd7f455eddf783207a41347ca020c238f370 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Mar 2015 16:41:02 +0000 Subject: [PATCH 11/23] Preparing to release to github. Added comments about the status of the core and insta parsers. --- README.md | 9 +++++++++ src/mw_parser/core.clj | 6 ++++-- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index b2ce28f..c584d61 100644 --- a/README.md +++ b/README.md @@ -188,6 +188,15 @@ and _operator_ is one of the simple arithmetic operators '+', '-', '*' and '/'. Note that '...neighbours are...' is equivalent to '...neighbours have state equal to...', and 'some neighbours...' is equivalent to 'more than 0 neighbours...' +### Roadmap + +The existing parser, *mw-parser.core*, works but is not well written. A much +better parser which does not yet completely work, *mw-parser.insta*, is also +included for the adventurous. + +I intend to replace *mw-parser.core* with *mw-parser.insta* as soon as +*mw-parser.insta* correctly parses all the test rules. + ## License Copyright © 2014 [Simon Brooke](mailto:simon@journeyman.cc) diff --git a/src/mw_parser/core.clj b/src/mw_parser/core.clj index 4f1159e..aafd595 100644 --- a/src/mw_parser/core.clj +++ b/src/mw_parser/core.clj @@ -20,8 +20,10 @@ ;; semantics - but that is buggy behaviour, which I'll try to fix over the next few weeks, not a ;; design fault. ;; -;; More significantly it does not generate useful error messages on failure. This is, I think, a much -;; more complex issue which I don't yet know how to address. +;; More significantly it does not generate useful error messages on failure. +;; +;; This is the parser that is actually used currently; but see also insta.clj, +;; which is potentially a much better parser but does not quite work yet. (ns mw-parser.core (:use mw-engine.utils From 1fb23ea9ce3472c420c93297816f0a3b90eafba3 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Mar 2015 17:17:59 +0000 Subject: [PATCH 12/23] Links to github repositories of related projects --- README.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/README.md b/README.md index c584d61..ec6f6b1 100644 --- a/README.md +++ b/README.md @@ -2,6 +2,14 @@ A rule parser for MicroWorld +## Part of the overall Microworld system + +While this code works and is interesting on its own, you also need at least +[https://github.com/simon-brooke/mw-engine](*mw-engine*) and +[https://github.com/simon-brooke/mw-ui](*mw-ui*). There will be other +modules in due course. + + ## Usage Main entry point is (parse-rule _string_), where string takes a form detailed From aa111df790da1948a724473068f910c9ff421f1d Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Mar 2015 17:32:18 +0000 Subject: [PATCH 13/23] Typo. --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index ec6f6b1..bcf6171 100644 --- a/README.md +++ b/README.md @@ -5,8 +5,8 @@ A rule parser for MicroWorld ## Part of the overall Microworld system While this code works and is interesting on its own, you also need at least -[https://github.com/simon-brooke/mw-engine](*mw-engine*) and -[https://github.com/simon-brooke/mw-ui](*mw-ui*). There will be other +[mw-engine](https://github.com/simon-brooke/mw-engine) and +[mw-ui](https://github.com/simon-brooke/mw-ui). There will be other modules in due course. From b11c1ba575cfdea57295ed8ce3c9f641d115ec6c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 28 Mar 2015 19:29:58 +0000 Subject: [PATCH 14/23] Added link to Goldsmith in README. --- README.md | 5 ++++- src/mw_parser/insta.clj | 2 ++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index bcf6171..76f662d 100644 --- a/README.md +++ b/README.md @@ -2,13 +2,16 @@ A rule parser for MicroWorld -## Part of the overall Microworld system +## Part of the overall MicroWorld system While this code works and is interesting on its own, you also need at least [mw-engine](https://github.com/simon-brooke/mw-engine) and [mw-ui](https://github.com/simon-brooke/mw-ui). There will be other modules in due course. +You can see MicroWorld in action [here](http://www.journeyman.cc/microworld/) - +but please don't be mean to my poor little server. If you want to run big maps +or complex rule-sets, please run it on your own machines. ## Usage diff --git a/src/mw_parser/insta.clj b/src/mw_parser/insta.clj index 9d220f9..3c59ccf 100644 --- a/src/mw_parser/insta.clj +++ b/src/mw_parser/insta.clj @@ -3,6 +3,8 @@ [clojure.string :only [split trim triml]]) (:require [instaparse.core :as insta])) +;; This is the 'next generation' parser - it is a much better parser than +;; mw-parser.core, but it doesn't completely work yet. (def grammar ;; in order to simplify translation into other natural languages, all From b08881a99ee19da4e5a9cc228d5f705f9d62bf1c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Mon, 28 Dec 2015 19:46:18 +0000 Subject: [PATCH 15/23] Added many more unit tests; parser appears to be working correctly, generator still needs work. But very promising! --- src/mw_parser/{insta.clj => declarative.clj} | 113 +++++++++++++------ test/mw_parser/declarative_test.clj | 83 ++++++++++++++ 2 files changed, 163 insertions(+), 33 deletions(-) rename src/mw_parser/{insta.clj => declarative.clj} (64%) create mode 100644 test/mw_parser/declarative_test.clj diff --git a/src/mw_parser/insta.clj b/src/mw_parser/declarative.clj similarity index 64% rename from src/mw_parser/insta.clj rename to src/mw_parser/declarative.clj index 9d220f9..6d9e1ca 100644 --- a/src/mw_parser/insta.clj +++ b/src/mw_parser/declarative.clj @@ -1,11 +1,21 @@ -(ns mw-parser.insta +(ns mw-parser.declarative (:use mw-engine.utils [clojure.string :only [split trim triml]]) (:require [instaparse.core :as insta])) +;; error thrown when an attempt is made to set a reserved property +(def reserved-properties-error + "The properties 'x' and 'y' of a cell are reserved and should not be set in rule actions") +;; error thrown when a rule cannot be parsed. Slots are for +;; (1) rule text +;; (2) cursor showing where in the rule text the error occurred +;; (3) the reason for the error +(def bad-parse-error "I did not understand:\n'%s'\n%s\n%s") + + (def grammar - ;; in order to simplify translation into other natural languages, all + ;; in order to simplify translation into other natural languages, all ;; TOKENS within the parser should be unambiguous "RULE := IF SPACE CONDITIONS SPACE THEN SPACE ACTIONS; CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | PROPERTY-CONDITION | NEIGHBOURS-CONDITION ; @@ -47,7 +57,8 @@ ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS ACTION := SIMPLE-ACTION | PROBABLE-ACTION; PROBABLE-ACTION := VALUE SPACE 'chance in' SPACE VALUE SPACE SIMPLE-ACTION; - SIMPLE-ACTION := SYMBOL SPACE 'should be' SPACE EXPRESSION + SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION + BECOMES := 'should be' SPACE := #' *'" ) @@ -59,6 +70,17 @@ (declare generate simplify) +(defn suitable-fragment? + "Return `true` if `tree-fragment` appears to be a tree fragment of the expected `type`." + [tree-fragment type] + (and (coll? tree-fragment)(= (first tree-fragment) type))) + +(defn assert-type + "If `tree-fragment` is not a tree fragment of the expected `type`, throw an exception." + [tree-fragment type] + (assert (suitable-fragment? tree-fragment type) + (throw (Exception. (format "Expected a %s fragment" type))))) + (defn generate-rule "From this `tree`, assumed to be a syntactically correct rule specification, generate and return the appropriate rule as a function of two arguments." @@ -79,15 +101,18 @@ (defn generate-conjunct-condition [tree] + (assert-type tree :CONJUNCT-CONDITION) (list 'and (generate (nth tree 1))(generate (nth tree 3)))) (defn generate-disjunct-condition [tree] + (assert-type tree :DISJUNCT-CONDITION) (list 'or (generate (nth tree 1))(generate (nth tree 3)))) (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))] @@ -95,10 +120,17 @@ (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}))) +(defn generate-multiple-actions + [tree] + nil) +;; (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") +;; (conj 'do (map + (defn generate "Generate code for this (fragment of a) parse tree" [tree] @@ -113,11 +145,13 @@ :CONJUNCT-CONDITION (generate-conjunct-condition tree) :PROPERTY-CONDITION (generate-property-condition tree) :SIMPLE-ACTION (generate-simple-action tree) + :ACTIONS (generate-multiple-actions tree) :SYMBOL (keyword (second tree)) :NUMBER (read-string (second tree)) :EQUIVALENCE '= :MORE '> :LESS '< + :COMPARATIVE (generate (second tree)) ;; :EXPRESSION (generate-expression tree) ;; :SIMPLE-EXPRESSION (map generate tree)) @@ -125,12 +159,12 @@ (defn simplify-qualifier - "Given that this `tree` fragment represents a qualifier, what + "Given that this `tree` fragment represents a qualifier, what qualifier is that?" [tree] - (cond + (cond (empty? tree) nil - (and (coll? tree) + (and (coll? tree) (member? (first tree) '(:EQUIVALENCE :COMPARATIVE))) tree (coll? (first tree)) (or (simplify-qualifier (first tree)) (simplify-qualifier (rest tree))) @@ -142,16 +176,22 @@ only two elements, the second is semantically sufficient." [tree] (if (= (count tree) 2) (simplify (nth tree 1)) tree)) - + + +(defn rule? + "Return true if the argument appears to be a parsed rule tree, else false." + [maybe-rule] + (and (coll? maybe-rule) (= (first maybe-rule) :RULE))) (defn simplify "Simplify/canonicalise this `tree`. Opportunistically replace complex fragments with semantically identical simpler fragments" [tree] - (if + (if (coll? tree) (case (first tree) :SPACE nil + :THEN nil :QUALIFIER (simplify-qualifier tree) :CONDITIONS (simplify-second-of-two tree) :CONDITION (simplify-second-of-two tree) @@ -168,31 +208,38 @@ (def parse-rule (insta/parser grammar)) -(defn compile-rule +(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." + [reason] + reason) + +(defn throw-parse-exception + "Construct a helpful error message from this `parser-error`, and throw an exception with that message." + [parser-error] + (assert (coll? parser-error) "Expected a paser error structure?") + (let + [ + ;; the error structure is a list, such that each element is a list of two items, and + ;; the first element in each sublist is a keyword. Easier to work with it as a map + error-map (reduce (fn [map item](merge map {(first item)(rest item)})) {} parser-error) + text (first (:text error-map)) + reason (explain-parse-error-reason (:reason error-map)) + ;; rules have only one line, by definition; we're interested in the column + 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 " ") "^"))) + ] + (throw (Exception. (format bad-parse-error text cursor reason))))) + +(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] - nil) -;; (generate (prune-tree (parse-rule rule)))) + (assert (string? rule)) + (let [tree (parse-rule rule)] + (if (rule? rule) (generate (simplify tree)) + (throw-parse-exception tree)))) - - -(compile-rule "if state is climax and some neighbours have state equal to fire then 3 chance in 5 state should be fire") - - -(compile-rule "if state is in grassland or pasture or heath and 4 neighbours have state equal to water then state should be village") - -(compile-rule "if 6 neighbours have state equal to water then state should be village") - -(compile-rule "if fertility is between 55 and 75 then state should be climax") - -(compile-rule "if state is forest then state should be climax") - - -(compile-rule "if state is in grassland or pasture or heath and 4 neighbours have state equal to water then state should be village") -(compile-rule "if altitude is less than 100 and state is forest then state should be climax and deer should be 3") -(compile-rule "if altitude is 100 or fertility is 25 then state should be heath and fertility should be 24.3") -(compile-rule "if altitude is 100 or fertility is 25 then state should be heath") - -(compile-rule "if deer is more than 2 and wolves is 0 and fertility is more than 20 then deer should be deer + 2") -(compile-rule "if deer is more than 1 and wolves is more than 1 then deer should be deer - wolves") -(compile-rule "if state is grassland and 4 neighbours have state equal to water then state should be village") diff --git a/test/mw_parser/declarative_test.clj b/test/mw_parser/declarative_test.clj new file mode 100644 index 0000000..ab6b04f --- /dev/null +++ b/test/mw_parser/declarative_test.clj @@ -0,0 +1,83 @@ +(ns mw-parser.declarative-test + (:use clojure.pprint + mw-engine.core + mw-engine.world) + (:require [clojure.test :refer :all] + [mw-parser.declarative :refer :all])) + +(deftest rules-tests + (testing "Rule parser - does not test whether generated functions actually work, just that something is generated!" + (is (rule? (parse-rule "if state is forest then state should be climax"))) + (is (rule? (parse-rule "if state is in grassland or pasture or heath then state should be village"))) + (is (rule? (parse-rule "if altitude is less than 100 and state is forest then state should be climax and deer should be 3"))) + (is (rule? (parse-rule "if altitude is 100 or fertility is 25 then state should be heath and fertility should be 24.3"))) + (is (rule? (parse-rule "if altitude is 100 or fertility is 25 then state should be heath"))) + (is (rule? (parse-rule "if deer is more than 2 and wolves is 0 and fertility is more than 20 then deer should be deer + 2"))) + (is (rule? (parse-rule "if deer is more than 1 and wolves is more than 1 then deer should be deer - wolves"))) + (is (rule? (parse-rule "if state is forest and fertility is between 55 and 75 then state should be climax"))) + (is (rule? (parse-rule "if fertility is between 55 and 75 then state should be climax"))) + (is (rule? (parse-rule "if altitude is less than 100 and state is forest then state should be climax and deer should be 3"))) + )) + +(deftest neighbours-rules-tests + (testing "Rules which relate to neighbours - hard!" + (is (rule? (parse-rule "if state is climax and some neighbours have state equal to fire then 3 chance in 5 state should be fire"))) + (is (rule? (parse-rule "if state is in grassland or pasture or heath and 4 neighbours have state equal to water then state should be village"))) + (is (rule? (parse-rule "if 6 neighbours have state equal to water then state should be village"))) + (is (rule? (parse-rule "if state is grassland and 4 neighbours have state equal to water then state should be village"))) + (is (rule? (parse-rule "if state is pasture and more than 3 neighbours have state equal to scrub then state should be scrub"))) + (is (rule? (parse-rule "if state is in grassland or pasture or heath and 4 neighbours have state equal to water then state should be village"))) + (is (rule? (parse-rule "if state is grassland and 4 neighbours have state equal to water then state should be village"))) + (is (rule? (parse-rule "if 6 neighbours have state equal to water then state should be village"))) + )) + +(deftest lhs-generators-tests + (testing "Generating left-hand-side fragments of rule functions from appropriate fragments of parse trees" + (is (generate-property-condition + '(:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest"))) + '(= (:state cell) :forest)) + (is (generate-property-condition + '(: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"))) + '(< (:fertility cell) 10)) + (is (generate-property-condition '(: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")))) + '(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")))) + '(or (= (:state cell) :forest) (= (:fertility cell) 10))) + )) + +(deftest rhs-generators-tests + (testing "Generating left-hand-side fragments of rule functions from appropriate fragments of parse trees" + (is (generate-simple-action + '(:SIMPLE-ACTION (:SYMBOL "state") (:BECOMES "should be") (:SYMBOL "climax"))) + '(merge cell {:state :climax})) + (is (generate-simple-action + '(:SIMPLE-ACTION (:SYMBOL "fertility") (:BECOMES "should be") (:NUMBER "10"))) + '(merge cell {:fertility 10})) + )) + +(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") + )) From 63e57753b0ceec20d933225bb39c2dc627fc9bfe Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 29 Dec 2015 14:09:39 +0000 Subject: [PATCH 16/23] 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" + )) From 77c7dc4a913a9e08984fb9e259eaf4df8bfe3bba Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Tue, 29 Dec 2015 14:11:36 +0000 Subject: [PATCH 17/23] 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" + )) From b23aae26ce4a7c0df457d46c2e7484acdb174fe4 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 2 Jan 2016 14:24:40 +0000 Subject: [PATCH 18/23] Commit before alph-ordering grammar. --- src/mw_parser/declarative.clj | 63 +++-- test/mw_parser/declarative_test.clj | 410 +++++++++++++++++++++++++++- 2 files changed, 446 insertions(+), 27 deletions(-) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index 1801b12..2a274b4 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -29,7 +29,8 @@ DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE; RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION; NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION; - QUALIFIER := COMPARATIVE SPACE THAN | EQUIVALENCE | IS SPACE QUALIFIER; + NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER; + QUALIFIER := NEGATED-QUALIFIER | IS COMPARATIVE SPACE THAN | EQUIVALENCE | IS SPACE QUALIFIER; QUANTIFIER := NUMBER | SOME | NONE | ALL; EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; COMPARATIVE := MORE | LESS; @@ -38,6 +39,7 @@ THEN := 'then'; THAN := 'than'; OR := 'or'; + NOT := 'not'; AND := 'and'; SOME := 'some'; NONE := 'no'; @@ -132,7 +134,10 @@ 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))) + :DISJUNCT-EXPRESSION (let [e (list 'some (list 'fn ['i] '(= i value)) (list 'quote expression))] + (list 'let ['value (list property 'cell)] + (if (= qualifier '=) e + (list 'not e)))) :RANGE-EXPRESSION (generate-ranged-property-condition tree property expression) (list qualifier (list property 'cell) expression))))) @@ -173,26 +178,32 @@ (if (coll? tree) (case (first tree) - :RULE (generate-rule tree) - :CONDITIONS (generate-conditions tree) + :ACTIONS (generate-multiple-actions tree) + :COMPARATIVE (generate (second tree)) :CONDITION (generate-condition tree) - ;; :NEIGHBOURS-CONDITION (generate-neighbours-condition tree) - :DISJUNCT-CONDITION (generate-disjunct-condition tree) + :CONDITIONS (generate-conditions tree) :CONJUNCT-CONDITION (generate-conjunct-condition tree) + :DISJUNCT-CONDITION (generate-disjunct-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)) - :NUMBER (read-string (second tree)) :EQUIVALENCE '= - :MORE '> + :EXPRESSION (generate (second tree)) :LESS '< - :COMPARATIVE (generate (second tree)) - ;; :EXPRESSION (generate-expression tree) - ;; :SIMPLE-EXPRESSION + :MORE '> + :NEGATED-QUALIFIER (case (generate (second tree)) + = 'not= + > '< + < '>) + ;; :NEIGHBOURS-CONDITION (generate-neighbours-condition tree) + :NUMERIC-EXPRESSION (generate-numeric-expression tree) + :NUMBER (read-string (second tree)) + :PROPERTY (list (generate (second tree)) 'cell) ;; dubious - may not be right + :QUALIFIER (generate (second tree)) + :RULE (generate-rule tree) + :SIMPLE-ACTION (generate-simple-action tree) + :SYMBOL (keyword (second tree)) + :VALUE (generate (second tree)) (map generate tree)) tree)) @@ -229,22 +240,24 @@ (if (coll? tree) (case (first tree) + :ACTION (simplify-second-of-two tree) + :ACTIONS (simplify-second-of-two tree) + :COMPARATIVE (simplify-second-of-two tree) + :CONDITION (simplify-second-of-two tree) + :CONDITIONS (simplify-second-of-two tree) + :EXPRESSION (simplify-second-of-two tree) + :QUANTIFIER (simplify-second-of-two tree) + :NOT nil + :PROPERTY (simplify-second-of-two tree) :SPACE nil :THEN nil - :QUALIFIER (simplify-qualifier tree) - :CONDITIONS (simplify-second-of-two tree) - :CONDITION (simplify-second-of-two tree) - :EXPRESSION (simplify-second-of-two tree) - :COMPARATIVE (simplify-second-of-two tree) - :QUANTIFIER (simplify-second-of-two tree) + ;; :QUALIFIER (simplify-qualifier tree) :VALUE (simplify-second-of-two tree) - :PROPERTY (simplify-second-of-two tree) - :ACTIONS (simplify-second-of-two tree) - :ACTION (simplify-second-of-two tree) (remove nil? (map simplify tree))) tree)) (def parse-rule + "Parse the argument, assumed to be a string in the correct syntax, and return a parse tree." (insta/parser grammar)) (defn explain-parse-error-reason @@ -277,7 +290,7 @@ [rule] (assert (string? rule)) (let [tree (simplify (parse-rule rule))] - (if (rule? rule) (generate tree) + (if (rule? tree) (eval (generate tree)) (throw-parse-exception tree)))) diff --git a/test/mw_parser/declarative_test.clj b/test/mw_parser/declarative_test.clj index 67b31d1..1b40eb9 100644 --- a/test/mw_parser/declarative_test.clj +++ b/test/mw_parser/declarative_test.clj @@ -95,7 +95,413 @@ "Exception thrown on attempt to set 'y'") )) -(deftest compilation-tests - (testing "Full compilation of rules" +(deftest correctness-tests + ;; these are, in so far as possible, the same as the correctness-tests in core-tests - i.e., the two compilers + ;; compile the same language. + (testing "Simplest possible rule" + (let [afn (compile-rule "if state is new then state should be grassland")] + (is (= (apply afn (list {:state :new} nil)) + {:state :grassland}) + "Rule fires when condition is met") + (is (nil? (apply afn (list {:state :forest} nil)))) + "Rule doesn't fire when condition isn't met")) + (testing "Condition conjunction rule" + (let [afn (compile-rule "if state is new and altitude is 0 then state should be water")] + (is (= (apply afn (list {:state :new :altitude 0} nil)) + {:state :water :altitude 0}) + "Rule fires when conditions are met") + (is (nil? (apply afn (list {:state :new :altitude 5} nil))) + "Rule does not fire: second condition not met") + (is (nil? (apply afn (list {:state :forest :altitude 0} nil))) + "Rule does not fire: first condition not met"))) + + (testing "Condition disjunction rule" + (let [afn (compile-rule "if state is new or state is waste then state should be grassland")] + (is (= (apply afn (list {:state :new} nil)) + {:state :grassland}) + "Rule fires: first condition met") + (is (= (apply afn (list {:state :waste} nil)) + {:state :grassland}) + "Rule fires: second condition met") + (is (nil? (apply afn (list {:state :forest} nil))) + "Rule does not fire: neither condition met"))) + + (testing "Simple negation rule" + (let [afn (compile-rule "if state is not new then state should be grassland")] + (is (nil? (apply afn (list {:state :new} nil))) + "Rule doesn't fire when condition isn't met") + (is (= (apply afn (list {:state :forest} nil)) + {:state :grassland}) + "Rule fires when condition is met"))) + + (testing "Can't set x or y properties" + (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'")) + + (testing "Simple list membership rule" + (let [afn (compile-rule "if state is in heath or scrub or forest then state should be climax")] + (is (= (apply afn (list {:state :heath} nil)) + {:state :climax}) + "Rule fires when condition is met") + (is (= (apply afn (list {:state :scrub} nil)) + {:state :climax}) + "Rule fires when condition is met") + (is (= (apply afn (list {:state :forest} nil)) + {:state :climax}) + "Rule fires when condition is met") + (is (nil? (apply afn (list {:state :grassland} nil))) + "Rule does not fire when condition is not met"))) + + (testing "Negated list membership rule" + (let [afn (compile-rule "if state is not in heath or scrub or forest then state should be climax")] + (is (nil? (apply afn (list {:state :heath} nil))) + "Rule does not fire when condition is not met") + (is (nil? (apply afn (list {:state :scrub} nil))) + "Rule does not fire when condition is not met") + (is (nil? (apply afn (list {:state :forest} nil))) + "Rule does not fire when condition is not met") + (is (= (apply afn (list {:state :grassland} nil)) + {:state :climax}) + "Rule fires when condition is met"))) + + (testing "Property is more than numeric-value" + (let [afn (compile-rule "if altitude is more than 200 then state should be snow")] + (is (= (apply afn (list {:altitude 201} nil)) + {:state :snow :altitude 201}) + "Rule fires when condition is met") + (is (nil? (apply afn (list {:altitude 200} nil))) + "Rule does not fire when condition is not met"))) + + (testing "Property is more than property" + (let [afn (compile-rule "if wolves are more than deer then deer should be 0")] + (is (= (apply afn (list {:deer 2 :wolves 3} nil)) + {:deer 0 :wolves 3}) + "Rule fires when condition is met") + (is (nil? (apply afn (list {:deer 3 :wolves 2} nil))) + "Rule does not fire when condition is not met"))) + + (testing "Property is less than numeric-value" + (let [afn (compile-rule "if altitude is less than 10 then state should be water")] + (is (= (apply afn (list {:altitude 9} nil)) + {:state :water :altitude 9}) + "Rule fires when condition is met") + (is (nil? (apply afn (list {:altitude 10} nil))) + "Rule does not fire when condition is not met"))) + + (testing "Property is less than property" + (let [afn (compile-rule "if wolves are less than deer then deer should be deer - wolves")] + (is (= (apply afn (list {:deer 3 :wolves 2} nil)) + {:deer 1 :wolves 2}) + "Rule fires when condition is met") + (is (nil? (apply afn (list {:deer 2 :wolves 3} nil))) + "Rule does not fire when condition is not met"))) + + (testing "Number neighbours have property equal to value" + (let [afn (compile-rule "if 3 neighbours have state equal to new then state should be water") + world (make-world 3 3)] + (is (= (apply afn (list {:x 0 :y 0} world)) + {:state :water :x 0 :y 0}) + "Rule fires when condition is met (in a new world all cells are new, corner cell has three neighbours)") + (is (nil? (apply afn (list {:x 1 :y 1} world))) + "Middle cell has eight neighbours, so rule does not fire.")) + (let [afn (compile-rule "if 3 neighbours are new then state should be water") + world (make-world 3 3)] + ;; 'are new' should be the same as 'have state equal to new' + (is (= (apply afn (list {:x 0 :y 0} world)) + {:state :water :x 0 :y 0}) + "Rule fires when condition is met (in a new world all cells are new, corner cell has three neighbours)") + (is (nil? (apply afn (list {:x 1 :y 1} world))) + "Middle cell has eight neighbours, so rule does not fire."))) + + (testing "Number neighbours have property more than numeric-value" + (let [afn (compile-rule "if 3 neighbours have altitude more than 10 then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11") + (compile-rule "if x is less than 2 then altitude should be 0")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :beach) + "Rule fires when condition is met (strip of altitude 11 down right hand side)") + (is (nil? (apply afn (list {:x 2 :y 1} world))) + "Middle cell of the strip has only two high neighbours, so rule should not fire."))) + + (testing "Number neighbours have property less than numeric-value" + (let [afn (compile-rule "if 5 neighbours have altitude less than 10 then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11") + (compile-rule "if x is less than 2 then altitude should be 0")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :beach) + "Rule fires when condition is met (strip of altitude 11 down right hand side)") + (is (nil? (apply afn (list {:x 2 :y 1} world))) + "Middle cell of the strip has two high neighbours, so rule should not fire."))) + + (testing "More than number neighbours have property equal to numeric-value" + (let [afn (compile-rule "if more than 2 neighbours have altitude equal to 11 then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11") + (compile-rule "if x is less than 2 then altitude should be 0")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :beach) + "Rule fires when condition is met (strip of altitude 11 down right hand side)") + (is (nil? (apply afn (list {:x 2 :y 1} world))) + "Middle cell of the strip has only two high neighbours, so rule should not fire."))) + + (testing "More than number neighbours have property equal to symbolic-value" + (let [afn (compile-rule "if more than 2 neighbours have state equal to grassland then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11 and state should be grassland") + (compile-rule "if x is less than 2 then altitude should be 0 and state should be water")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :beach) + "Rule fires when condition is met (strip of altitude 11 down right hand side)") + (is (nil? (apply afn (list {:x 2 :y 1} world))) + "Middle cell of the strip has only two high neighbours, so rule should not fire.")) + (let [afn (compile-rule "if more than 2 neighbours are grassland then state should be beach") + ;; 'are grassland' should mean the same as 'have state equal to grassland'. + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11 and state should be grassland") + (compile-rule "if x is less than 2 then altitude should be 0 and state should be water")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :beach) + "Rule fires when condition is met (strip of altitude 11 down right hand side)") + (is (nil? (apply afn (list {:x 2 :y 1} world))) + "Middle cell of the strip has only two high neighbours, so rule should not fire.")) + ) + + (testing "Fewer than number neighbours have property equal to numeric-value" + (let [afn (compile-rule "if fewer than 3 neighbours have altitude equal to 11 then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11") + (compile-rule "if x is less than 2 then altitude should be 0")))] + (is (= (:state (apply afn (list {:x 2 :y 1} world))) :beach) + "Rule fires when condition is met (Middle cell of the strip has only two high neighbours)") + (is (nil? (apply afn (list {:x 1 :y 1} world))) + "Middle cell of world has three high neighbours, so rule should not fire."))) + + (testing "Fewer than number neighbours have property equal to symbolic-value" + (let [afn (compile-rule "if fewer than 3 neighbours have state equal to grassland then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11 and state should be grassland") + (compile-rule "if x is less than 2 then altitude should be 0 and state should be water")))] + (is (= (:state (apply afn (list {:x 2 :y 1} world))) :beach) + "Rule fires when condition is met (Middle cell of the strip has only two high neighbours)") + (is (nil? (apply afn (list {:x 1 :y 1} world))) + "Middle cell of world has three high neighbours, so rule should not fire."))) + +;; some neighbours have property equal to value + (testing "Some neighbours have property equal to numeric-value" + (let [afn (compile-rule "if some neighbours have altitude equal to 11 then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11") + (compile-rule "if x is less than 2 then altitude should be 0")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :beach) + "Rule fires when condition is met (strip of altitude 11 down right hand side)") + (is (nil? (apply afn (list {:x 0 :y 1} world))) + "Left hand side of world has no high neighbours, so rule should not fire."))) + + (testing "Some neighbours have property equal to symbolic-value" + (let [afn (compile-rule "if some neighbours have state equal to grassland then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11 and state should be grassland") + (compile-rule "if x is less than 2 then altitude should be 0 and state should be water")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :beach) + "Rule fires when condition is met (strip of altitude 11 down right hand side)") + (is (nil? (apply afn (list {:x 0 :y 1} world))) + "Left hand side of world has no high neighbours, so rule should not fire."))) + +;; more than number neighbours have property more than numeric-value + (testing "More than number neighbours have property more than symbolic-value" + (let [afn (compile-rule "if more than 2 neighbours have altitude more than 10 then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11 and state should be grassland") + (compile-rule "if x is less than 2 then altitude should be 0 and state should be water")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :beach) + "Rule fires when condition is met (strip of altitude 11 down right hand side)") + (is (nil? (apply afn (list {:x 2 :y 1} world))) + "Middle cell of the strip has only two high neighbours, so rule should not fire."))) + +;; fewer than number neighbours have property more than numeric-value + (testing "Fewer than number neighbours have property more than numeric-value" + (let [afn (compile-rule "if fewer than 3 neighbours have altitude more than 10 then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11") + (compile-rule "if x is less than 2 then altitude should be 0")))] + (is (= (:state (apply afn (list {:x 2 :y 1} world))) :beach) + "Rule fires when condition is met (Middle cell of the strip has only two high neighbours)") + (is (nil? (apply afn (list {:x 1 :y 1} world))) + "Middle cell of world has three high neighbours, so rule should not fire."))) + +;; some neighbours have property more than numeric-value + (testing "Some neighbours have property more than numeric-value" + (let [afn (compile-rule "if some neighbours have altitude more than 10 then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11") + (compile-rule "if x is less than 2 then altitude should be 0")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :beach) + "Rule fires when condition is met (strip of altitude 11 down right hand side)") + (is (nil? (apply afn (list {:x 0 :y 1} world))) + "Left hand side of world has no high neighbours, so rule should not fire."))) + +;; more than number neighbours have property less than numeric-value + (testing "More than number neighbours have property less than numeric-value" + (let [afn (compile-rule "if more than 4 neighbours have altitude less than 10 then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11") + (compile-rule "if x is less than 2 then altitude should be 0")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :beach) + "Rule fires when condition is met (strip of altitude 11 down right hand side)") + (is (nil? (apply afn (list {:x 2 :y 1} world))) + "Middle cell of the strip has only three low neighbours, so rule should not fire."))) + +;; fewer than number neighbours have property less than numeric-value + (testing "Fewer than number neighbours have property less than numeric-value" + (let [afn (compile-rule "if fewer than 4 neighbours have altitude less than 10 then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is 2 then altitude should be 11") + (compile-rule "if x is less than 2 then altitude should be 0")))] + (is (nil? (apply afn (list {:x 1 :y 1} world))) + "Centre cell has five low neighbours, so rule should not fire") + (is (= (:state (apply afn (list {:x 2 :y 1} world))) :beach) + "Middle cell of the strip has only three low neighbours, so rule should fire."))) + +;; some neighbours have property less than numeric-value + (testing "Some number neighbours have property less than numeric-value" + (let [afn (compile-rule "if some neighbours have altitude less than 10 then state should be beach") + world (transform-world + (make-world 3 3) + (list (compile-rule "if x is less than 2 then altitude should be 11") + (compile-rule "if x is 2 then altitude should be 0")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :beach) + "Rule fires when condition is met (strip of altitude 0 down right hand side)") + (is (nil? (apply afn (list {:x 0 :y 1} world))) + "Left of world is all high, so rule should not fire."))) + + +;; 'single action' already tested in 'condition' tests above +;; action and actions + (testing "Conjunction of actions" + (let [afn (compile-rule "if state is new then state should be grassland and fertility should be 0")] + (is (= (apply afn (list {:state :new} nil)) + {:state :grassland :fertility 0}) + "Both actions are executed"))) + +;; 'property should be symbolic-value' and 'property should be numeric-value' +;; already tested in tests above + +;; number chance in number property should be value + (testing "Syntax of probability rule - action of real probability very hard to test" + (let [afn (compile-rule "if state is forest then 5 chance in 5 state should be climax")] + (is (= (:state (apply afn (list {:state :forest} nil))) :climax) + "five chance in five should fire every time")) + (let [afn (compile-rule "if state is forest then 0 chance in 5 state should be climax")] + (is (nil? (apply afn (list {:state :forest} nil))) + "zero chance in five should never fire"))) + +;; property operator numeric-value + (testing "Arithmetic action: addition of number" + (let [afn (compile-rule "if state is climax then fertility should be fertility + 1")] + (is (= (:fertility + (apply afn (list {:state :climax :fertility 0} nil))) + 1) + "Addition is executed"))) + + (testing "Arithmetic action: addition of property value" + (let [afn (compile-rule "if state is climax then fertility should be fertility + leaf-fall")] + (is (= (:fertility + (apply afn + (list {:state :climax + :fertility 0 + :leaf-fall 1} nil))) + 1) + "Addition is executed"))) + + (testing "Arithmetic action: subtraction of number" + (let [afn (compile-rule "if state is crop then fertility should be fertility - 1")] + (is (= (:fertility + (apply afn (list {:state :crop :fertility 2} nil))) + 1) + "Action is executed"))) + + (testing "Arithmetic action: subtraction of property value" + (let [afn (compile-rule "if wolves are more than 0 then deer should be deer - wolves")] + (is (= (:deer + (apply afn + (list {:deer 3 + :wolves 2} nil))) + 1) + "Action is executed"))) + + (testing "Arithmetic action: multiplication by number" + (let [afn (compile-rule "if deer are more than 1 then deer should be deer * 2")] + (is (= (:deer + (apply afn (list {:deer 2} nil))) + 4) + "Action is executed"))) + + (testing "Arithmetic action: multiplication by property value" + (let [afn (compile-rule "if state is crop then deer should be deer * deer")] + (is (= (:deer + (apply afn + (list {:state :crop :deer 2} nil))) + 4) + "Action is executed"))) + + (testing "Arithmetic action: division by number" + (let [afn (compile-rule "if wolves are more than 0 then deer should be deer / 2")] + (is (= (:deer + (apply afn (list {:deer 2 :wolves 1} nil))) + 1) + "Action is executed"))) + + (testing "Arithmetic action: division by property value" + (let [afn (compile-rule "if wolves are more than 0 then deer should be deer / wolves")] + (is (= (:deer + (apply afn + (list {:deer 2 :wolves 2} nil))) + 1) + "Action is executed"))) + +;; simple within distance + (testing "Number neighbours within distance have property equal to value" + (let [afn (compile-rule "if 8 neighbours within 2 have state equal to new then state should be water") + world (make-world 5 5)] + (is (= (apply afn (list {:x 0 :y 0} world)) + {:state :water :x 0 :y 0}) + "Rule fires when condition is met (in a new world all cells are new, corner cell has eight neighbours within two)") + (is (nil? (apply afn (list {:x 1 :y 1} world))) + "Middle cell has twenty-four neighbours within two, so rule does not fire."))) + +;; comparator within distance + (testing "More than number neighbours within distance have property equal to symbolic-value" + (let [afn (compile-rule "if more than 7 neighbours within 2 have state equal to grassland and more than 7 neighbours within 2 have state equal to water then state should be beach") + ;; 5x5 world, strip of high ground two cells wide down left hand side + ;; xxooo + ;; xxooo + ;; xxooo + ;; xxooo + ;; xxooo + world (transform-world + (make-world 5 5) + (list (compile-rule "if x is less than 2 then altitude should be 11 and state should be grassland") + (compile-rule "if x is more than 1 then altitude should be 0 and state should be water")))] + (is (= (:state (apply afn (list {:x 2 :y 2} world))) :beach) + "Rule fires when condition is met (strip of altitude 11 down right hand side)") + (is (nil? (apply afn (list {:x 0 :y 1} world))) + "Middle cell of the strip has only two high neighbours, so rule should not fire.")) )) From ac73639533420398d0467c7fc36ee02e69b82d5c Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 2 Jan 2016 15:09:55 +0000 Subject: [PATCH 19/23] Now passing on all but neighbours rules, which I knew I hadn't dealt with --- src/mw_parser/declarative.clj | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index 2a274b4..c6a6674 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -30,7 +30,8 @@ RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION; NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION; NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER; - QUALIFIER := NEGATED-QUALIFIER | IS COMPARATIVE SPACE THAN | EQUIVALENCE | IS SPACE QUALIFIER; + COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN; + QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER; QUANTIFIER := NUMBER | SOME | NONE | ALL; EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; COMPARATIVE := MORE | LESS; @@ -180,6 +181,7 @@ (case (first tree) :ACTIONS (generate-multiple-actions tree) :COMPARATIVE (generate (second tree)) + :COMPARATIVE-QUALIFIER (generate (nth tree 2)) :CONDITION (generate-condition tree) :CONDITIONS (generate-conditions tree) :CONJUNCT-CONDITION (generate-conjunct-condition tree) From 717097070a54d27db2923462577e4eaefa4a66c6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sun, 3 Jan 2016 14:59:24 +0000 Subject: [PATCH 20/23] State of play just before going back to Glasgow. Doesn't fully work yet, but close. --- src/mw_parser/declarative.clj | 35 +++++++++++++++++++++++++++++------ 1 file changed, 29 insertions(+), 6 deletions(-) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index c6a6674..8f73c4f 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -32,7 +32,7 @@ NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER; COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN; QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER; - QUANTIFIER := NUMBER | SOME | NONE | ALL; + QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER; EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; COMPARATIVE := MORE | LESS; DISJUNCT-VALUE := VALUE | VALUE SPACE OR SPACE DISJUNCT-VALUE; @@ -125,6 +125,14 @@ 'upper (list 'max l1 l2)] (list 'and (list '>= pv 'lower)(list '<= pv 'upper))))) +(defn generate-disjunct-condition + "Generate a property condition where the expression is a disjunct expression" + [tree property qualifier expression] + (let [e (list 'some (list 'fn ['i] '(= i value)) (list 'quote expression))] + (list 'let ['value (list property 'cell)] + (if (= qualifier '=) e + (list 'not e))))) + (defn generate-property-condition ([tree] (assert-type tree :PROPERTY-CONDITION) @@ -135,10 +143,7 @@ qualifier (generate (nth tree 2)) expression (generate (nth tree 3))] (case expression-type - :DISJUNCT-EXPRESSION (let [e (list 'some (list 'fn ['i] '(= i value)) (list 'quote expression))] - (list 'let ['value (list property 'cell)] - (if (= qualifier '=) e - (list 'not e)))) + :DISJUNCT-EXPRESSION (generate-disjunct-condition tree property qualifier expression) :RANGE-EXPRESSION (generate-ranged-property-condition tree property expression) (list qualifier (list property 'cell) expression))))) @@ -173,6 +178,24 @@ :SYMBOL (list (keyword (second (second tree))) 'cell) (generate (second tree)))) +;; (defn generate-neighbours-condition +;; "Generate code for a condition which refers to neighbours." +;; ([tree] +;; (let [q (second tree)] +;; (if (number? q) +;; (generate-neighbours-condition '= q +;; ([comp1 quantity property value remainder comp2 distance] +;; [(list comp1 +;; (list 'count +;; (list 'get-neighbours-with-property-value 'world +;; '(cell :x) '(cell :y) distance +;; (keyword property) (keyword-or-numeric value) comp2)) +;; quantity) +;; remainder]) +;; ([comp1 quantity property value remainder comp2] +;; (gen-neighbours-condition comp1 quantity property value remainder comp2 1))) + + (defn generate "Generate code for this (fragment of a) parse tree" [tree] @@ -197,7 +220,7 @@ = 'not= > '< < '>) - ;; :NEIGHBOURS-CONDITION (generate-neighbours-condition tree) +;; :NEIGHBOURS-CONDITION (generate-neighbours-condition tree) :NUMERIC-EXPRESSION (generate-numeric-expression tree) :NUMBER (read-string (second tree)) :PROPERTY (list (generate (second tree)) 'cell) ;; dubious - may not be right From 547edbe56a07276a944c7a6dee472bf5627cc1d9 Mon Sep 17 00:00:00 2001 From: simon Date: Fri, 4 Mar 2016 01:02:17 +0000 Subject: [PATCH 21/23] Added the simplifier, although it's not currently used, I don't think --- project.clj | 4 +- src/mw_parser/declarative.clj | 77 +++++++++++++++++++++-------- src/mw_parser/simplifier.clj | 92 +++++++++++++++++++++++++++++++++++ 3 files changed, 151 insertions(+), 22 deletions(-) create mode 100644 src/mw_parser/simplifier.clj diff --git a/project.clj b/project.clj index 73fd1c1..d48db45 100644 --- a/project.clj +++ b/project.clj @@ -12,7 +12,7 @@ :url "http://www.gnu.org/licenses/gpl-2.0.html"} :plugins [[lein-marginalia "0.7.1"]] :dependencies [[org.clojure/clojure "1.6.0"] - [org.clojure/tools.trace "0.7.8"] - [instaparse "1.3.5"] + [org.clojure/tools.trace "0.7.9"] + [instaparse "1.4.1"] [mw-engine "0.1.5-SNAPSHOT"] ]) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index 8f73c4f..40804c6 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -22,7 +22,8 @@ DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS; CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS; CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; - NEIGHBOURS-CONDITION := QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; + WITHIN-CONDITION := NEIGHBOURS-CONDITION SPACE WITHIN SPACE NUMERIC-EXPRESSION; + NEIGHBOURS-CONDITION := WITHIN-CONDITION | QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION; EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; @@ -46,6 +47,7 @@ NONE := 'no'; ALL := 'all' BETWEEN := 'between'; + WITHIN := 'within'; IN := 'in'; MORE := 'more'; LESS := 'less' | 'fewer'; @@ -178,22 +180,57 @@ :SYMBOL (list (keyword (second (second tree))) 'cell) (generate (second tree)))) -;; (defn generate-neighbours-condition -;; "Generate code for a condition which refers to neighbours." -;; ([tree] -;; (let [q (second tree)] -;; (if (number? q) -;; (generate-neighbours-condition '= q -;; ([comp1 quantity property value remainder comp2 distance] -;; [(list comp1 -;; (list 'count -;; (list 'get-neighbours-with-property-value 'world -;; '(cell :x) '(cell :y) distance -;; (keyword property) (keyword-or-numeric value) comp2)) -;; quantity) -;; remainder]) -;; ([comp1 quantity property value remainder comp2] -;; (gen-neighbours-condition comp1 quantity property value remainder comp2 1))) +(defn generate-neighbours-condition + "Generate code for a condition which refers to neighbours." + ([tree] + (generate-neighbours-condition tree (first (second tree)))) + ([tree quantifier-type] + (let [quantifier (second (second tree)) + pc (generate (nth tree 4))] + (case quantifier-type + :NUMBER (generate-neighbours-condition '= (read-string quantifier) pc 1) + :SOME (generate-neighbours-condition '> 0 pc 1) + :QUANTIFIER + (let [comparative (generate (simplify (second quantifier))) + value (simplify (nth quantifier 5))] + (generate-neighbours-condition comparative value pc 1))))) + ([comp1 quantity property-condition distance] + (list comp1 + (list 'count (list 'remove false (list 'map (list 'fn ['cell] property-condition) '(get-neighbours cell world distance)))) quantity)) + ([comp1 quantity property-condition] + (generate-neighbours-condition comp1 quantity property-condition 1))) + +;; (def s1 "if 3 neighbours have state equal to forest then state should be forest") +;; (def s2 "if some neighbours have state equal to forest then state should be forest") +;; (def s3 "if more than 3 neighbours have state equal to forest then state should be forest") +;; (def s4 "if fewer than 3 neighbours have state equal to forest then state should be forest") +;; (def s5 "if all neighbours have state equal to forest then state should be forest") +;; (def s6 "if more than 3 neighbours within 2 have state equal to forest then state should be forest") + +;; (nth (simplify (parse-rule s1)) 2) +;; (second (nth (simplify (parse-rule s1)) 2)) +;; (nth (simplify (parse-rule s2)) 2) +;; (map simplify (nth (simplify (parse-rule s2)) 2)) +;; ;; (second (nth (simplify (parse-rule s2)) 2)) +;; ;; (nth (simplify (parse-rule s3)) 2) +;; (second (nth (simplify (parse-rule s3)) 2)) +;; (map simplify (second (nth (simplify (parse-rule s3)) 2))) +;; ;; (nth (simplify (parse-rule s4)) 2) +;; ;; (second (nth (simplify (parse-rule s4)) 2)) +;; ;; (nth (simplify (parse-rule s5)) 2) +;; ;; (second (nth (simplify (parse-rule s5)) 2)) +;; ;; (nth (simplify (parse-rule s6)) 2) +;; ;; (second (nth (simplify (parse-rule s6)) 2)) + +;; ;; (generate (nth (nth (simplify (parse-rule s5)) 2) 4)) +;; ;; (generate (nth (simplify (parse-rule s2)) 2)) +;; ;; (generate (nth (simplify (parse-rule s1)) 2)) + + +;; (generate-neighbours-condition '= 3 '(= (:state cell) :forest) 1) +;; (generate-neighbours-condition (nth (simplify (parse-rule s3)) 2)) +;; (generate-neighbours-condition (nth (simplify (parse-rule s2)) 2)) +;; (generate-neighbours-condition (nth (simplify (parse-rule s1)) 2)) (defn generate @@ -209,7 +246,6 @@ :CONDITIONS (generate-conditions tree) :CONJUNCT-CONDITION (generate-conjunct-condition tree) :DISJUNCT-CONDITION (generate-disjunct-condition tree) - :PROPERTY-CONDITION (generate-property-condition tree) :DISJUNCT-EXPRESSION (generate (nth tree 2)) :DISJUNCT-VALUE (generate-disjunct-value tree) :EQUIVALENCE '= @@ -220,10 +256,11 @@ = 'not= > '< < '>) -;; :NEIGHBOURS-CONDITION (generate-neighbours-condition tree) + :NEIGHBOURS-CONDITION (generate-neighbours-condition tree) :NUMERIC-EXPRESSION (generate-numeric-expression tree) :NUMBER (read-string (second tree)) :PROPERTY (list (generate (second tree)) 'cell) ;; dubious - may not be right + :PROPERTY-CONDITION (generate-property-condition tree) :QUALIFIER (generate (second tree)) :RULE (generate-rule tree) :SIMPLE-ACTION (generate-simple-action tree) @@ -271,7 +308,7 @@ :CONDITION (simplify-second-of-two tree) :CONDITIONS (simplify-second-of-two tree) :EXPRESSION (simplify-second-of-two tree) - :QUANTIFIER (simplify-second-of-two tree) +;; :QUANTIFIER (simplify-second-of-two tree) :NOT nil :PROPERTY (simplify-second-of-two tree) :SPACE nil diff --git a/src/mw_parser/simplifier.clj b/src/mw_parser/simplifier.clj new file mode 100644 index 0000000..9943256 --- /dev/null +++ b/src/mw_parser/simplifier.clj @@ -0,0 +1,92 @@ +(ns mw-parser.simplifier + (:use mw-engine.utils + mw-parser.parser)) + +(declare simplify) + +(defn simplify-qualifier + "Given that this `tree` fragment represents a qualifier, what + qualifier is that?" + [tree] + (cond + (empty? tree) nil + (and (coll? tree) + (member? (first tree) '(:EQUIVALENCE :COMPARATIVE))) tree + (coll? (first tree)) (or (simplify-qualifier (first tree)) + (simplify-qualifier (rest tree))) + (coll? tree) (simplify-qualifier (rest tree)) + true tree)) + +(defn simplify-second-of-two + "There are a number of possible simplifications such that if the `tree` has + only two elements, the second is semantically sufficient." + [tree] + (if (= (count tree) 2) (simplify (nth tree 1)) tree)) + + +(defn simplify-some + "'some' is the same as 'more than zero'" + [tree] + [:COMPARATIVE '> 0]) + +(defn simplify-none + "'none' is the same as 'zero'" + [tree] + [:COMPARATIVE '= 0]) + +(defn simplify-all + "'all' isn't actually the same as 'eight', because cells at the edges of the world have + fewer than eight neighbours; but it's a simplifying (ha!) assumption for now." + [tree] + [:COMPARATIVE '= 8]) + +(defn simplify-quantifier + "If this quantifier is a number, 'simplifiy' it into a comparative whose operator is '=' + and whose quantity is that number. This is actually more complicated but makes generation easier." + [tree] + (if (number? (second tree)) [:COMPARATIVE '= (second tree)] (simplify (second tree)))) + +(defn simplify + "Simplify/canonicalise this `tree`. Opportunistically replace complex fragments with + semantically identical simpler fragments" + [tree] + (if + (coll? tree) + (case (first tree) + :SPACE nil + :QUALIFIER (simplify-qualifier tree) + :CONDITIONS (simplify-second-of-two tree) + :CONDITION (simplify-second-of-two tree) + :EXPRESSION (simplify-second-of-two tree) + :COMPARATIVE (simplify-second-of-two tree) + :QUANTIFIER (simplify-quantifier tree) + :VALUE (simplify-second-of-two tree) + :PROPERTY (simplify-second-of-two tree) + :ACTIONS (simplify-second-of-two tree) + :ACTION (simplify-second-of-two tree) + :ALL (simplify-all tree) + :SOME (simplify-some tree) + :NONE (simplify-none tree) + (remove nil? (map simplify tree))) + tree)) + +(simplify (parse-rule "if state is climax and 4 neighbours have state equal to fire then 3 chance in 5 state should be fire")) +(simplify (parse-rule "if state is climax and no neighbours have state equal to fire then 3 chance in 5 state should be fire")) + +(simplify (parse-rule "if state is in grassland or pasture or heath and more than 4 neighbours have state equal to water then state should be village")) + +(simplify (parse-rule "if 6 neighbours have state equal to water then state should be village")) + +(simplify (parse-rule "if fertility is between 55 and 75 then state should be climax")) + +(simplify (parse-rule "if state is forest then state should be climax")) + + +(simplify (parse-rule "if state is in grassland or pasture or heath and more than 4 neighbours have state equal to water then state should be village")) +(simplify (parse-rule "if altitude is less than 100 and state is forest then state should be climax and deer should be 3")) +(simplify (parse-rule "if altitude is 100 or fertility is 25 then state should be heath and fertility should be 24.3")) +(simplify (parse-rule "if altitude is 100 or fertility is 25 then state should be heath")) + +(simplify (parse-rule "if deer is more than 2 and wolves is 0 and fertility is more than 20 then deer should be deer + 2")) +(simplify (parse-rule "if deer is more than 1 and wolves is more than 1 then deer should be deer - wolves")) +(simplify (parse-rule "if state is grassland and 4 neighbours have state equal to water then state should be village")) From 5db1055027b59212d8c12574129289d5a6a8a4d6 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Wed, 3 Aug 2016 10:07:18 +0100 Subject: [PATCH 22/23] Some work on unit testing declarative parser. --- src/mw_parser/bulk.clj | 12 ++++---- src/mw_parser/declarative.clj | 47 +++++++++++++++++------------ test/mw_parser/declarative_test.clj | 29 +++++++++--------- 3 files changed, 48 insertions(+), 40 deletions(-) diff --git a/src/mw_parser/bulk.clj b/src/mw_parser/bulk.clj index b49ca0a..b4674ec 100644 --- a/src/mw_parser/bulk.clj +++ b/src/mw_parser/bulk.clj @@ -8,32 +8,32 @@ [clojure.string :only [split trim]]) (:import (java.io BufferedReader StringReader))) -(defn comment? +(defn comment? "Is this `line` a comment?" [line] (or (empty? (trim line)) (member? (first line) '(nil \# \;)))) -(defn parse-string +(defn parse-string "Parse rules from successive lines in this `string`, assumed to have multiple lines delimited by the new-line character. Return a list of S-expressions." [string] ;; TODO: tried to do this using with-open, but couldn't make it work. (map parse-rule (remove comment? (split string #"\n")))) -(defn parse-file +(defn parse-file "Parse rules from successive lines in the file loaded from this `filename`. Return a list of S-expressions." [filename] (parse-string (slurp filename))) (defn compile-string - "Compile each non-comment line of this `string` into an executable anonymous + "Compile each non-comment line of this `string` into an executable anonymous function, and return the sequence of such functions." [string] (map #(compile-rule % true) (remove comment? (split string #"\n")))) -(defn compile-file - "Compile each non-comment line of the file indicated by this `filename` into +(defn compile-file + "Compile each non-comment line of the file indicated by this `filename` into an executable anonymous function, and return the sequence of such functions." [filename] (compile-string (slurp filename))) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index 8f73c4f..c171194 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -116,22 +116,28 @@ (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))))) + (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-disjunct-condition - "Generate a property condition where the expression is a disjunct expression" - [tree property qualifier expression] - (let [e (list 'some (list 'fn ['i] '(= i value)) (list 'quote expression))] - (list 'let ['value (list property 'cell)] - (if (= qualifier '=) e - (list 'not e))))) +(defn generate-disjunct-property-condition + "Generate a property condition where the expression is a disjunct expression. + TODO: this is definitely still wrong!" + ([tree] + (let [property (generate (nth tree 1)) + qualifier (generate (nth tree 2)) + expression (generate (nth tree 3))] + (generate-disjunct-property-condition tree property qualifier expression))) + ([tree property qualifier expression] + (let [e (list 'some (list 'fn ['i] '(= i value)) (list 'quote expression))] + (list 'let ['value (list property 'cell)] + (if (= qualifier '=) e + (list 'not e)))))) (defn generate-property-condition ([tree] @@ -143,7 +149,7 @@ qualifier (generate (nth tree 2)) expression (generate (nth tree 3))] (case expression-type - :DISJUNCT-EXPRESSION (generate-disjunct-condition tree property qualifier expression) + :DISJUNCT-EXPRESSION (generate-disjunct-property-condition tree property qualifier expression) :RANGE-EXPRESSION (generate-ranged-property-condition tree property expression) (list qualifier (list property 'cell) expression))))) @@ -157,10 +163,9 @@ (list 'merge 'cell {property expression})))) (defn generate-multiple-actions - [tree] - nil) -;; (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") -;; (conj 'do (map + [tree] + (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") + (conj 'do (map generate-simple-action (rest tree)))) (defn generate-disjunct-value "Generate a disjunct value. Essentially what we need here is to generate a @@ -232,6 +237,8 @@ (map generate tree)) tree)) +(generate '(:PROPERTY-CONDITION (:SYMBOL "wolves") (:QUALIFIER (:COMPARATIVE-QUALIFIER (:IS "are") (:MORE "more") (:THAN "than"))) (:SYMBOL "deer"))) + (defn simplify-qualifier "Given that this `tree` fragment represents a qualifier, what diff --git a/test/mw_parser/declarative_test.clj b/test/mw_parser/declarative_test.clj index 1b40eb9..b3eaed7 100644 --- a/test/mw_parser/declarative_test.clj +++ b/test/mw_parser/declarative_test.clj @@ -179,13 +179,14 @@ (is (nil? (apply afn (list {:altitude 200} nil))) "Rule does not fire when condition is not met"))) - (testing "Property is more than property" - (let [afn (compile-rule "if wolves are more than deer then deer should be 0")] - (is (= (apply afn (list {:deer 2 :wolves 3} nil)) - {:deer 0 :wolves 3}) - "Rule fires when condition is met") - (is (nil? (apply afn (list {:deer 3 :wolves 2} nil))) - "Rule does not fire when condition is not met"))) +;; TODO: this one is very tricky and will require a rethink of the way conditions are parsed. +;; (testing "Property is more than property" +;; (let [afn (compile-rule "if wolves are more than deer then deer should be 0")] +;; (is (= (apply afn (list {:deer 2 :wolves 3} nil)) +;; {:deer 0 :wolves 3}) +;; "Rule fires when condition is met") +;; (is (nil? (apply afn (list {:deer 3 :wolves 2} nil))) +;; "Rule does not fire when condition is not met"))) (testing "Property is less than numeric-value" (let [afn (compile-rule "if altitude is less than 10 then state should be water")] @@ -195,13 +196,13 @@ (is (nil? (apply afn (list {:altitude 10} nil))) "Rule does not fire when condition is not met"))) - (testing "Property is less than property" - (let [afn (compile-rule "if wolves are less than deer then deer should be deer - wolves")] - (is (= (apply afn (list {:deer 3 :wolves 2} nil)) - {:deer 1 :wolves 2}) - "Rule fires when condition is met") - (is (nil? (apply afn (list {:deer 2 :wolves 3} nil))) - "Rule does not fire when condition is not met"))) +;; (testing "Property is less than property" +;; (let [afn (compile-rule "if wolves are less than deer then deer should be deer - wolves")] +;; (is (= (apply afn (list {:deer 3 :wolves 2} nil)) +;; {:deer 1 :wolves 2}) +;; "Rule fires when condition is met") +;; (is (nil? (apply afn (list {:deer 2 :wolves 3} nil))) +;; "Rule does not fire when condition is not met"))) (testing "Number neighbours have property equal to value" (let [afn (compile-rule "if 3 neighbours have state equal to new then state should be water") From e40d89fdefb947e8fccf0291fa017e08c498a572 Mon Sep 17 00:00:00 2001 From: simon Date: Wed, 3 Aug 2016 17:41:48 +0100 Subject: [PATCH 23/23] Very considerable progress on the new parser. The deer/wolves rules still fail, as does one complicated form of neighbours rule; but I'm almost there. --- src/mw_parser/declarative.clj | 109 ++++++++++++++-------------- test/mw_parser/declarative_test.clj | 31 +++++--- 2 files changed, 76 insertions(+), 64 deletions(-) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index 46bf5be..8bea7dd 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -24,7 +24,7 @@ CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; WITHIN-CONDITION := NEIGHBOURS-CONDITION SPACE WITHIN SPACE NUMERIC-EXPRESSION; NEIGHBOURS-CONDITION := WITHIN-CONDITION | QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; - PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION; + PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION | VALUE; EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE; @@ -49,7 +49,7 @@ BETWEEN := 'between'; WITHIN := 'within'; IN := 'in'; - MORE := 'more'; + MORE := 'more' | 'greater'; LESS := 'less' | 'fewer'; OPERATOR := '+' | '-' | '*' | '/'; NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors'; @@ -75,10 +75,13 @@ (declare generate simplify) + (defn suitable-fragment? "Return `true` if `tree-fragment` appears to be a tree fragment of the expected `type`." [tree-fragment type] - (and (coll? tree-fragment)(= (first tree-fragment) type))) + (and (coll? tree-fragment) + (= (first tree-fragment) type))) + (defn assert-type "If `tree-fragment` is not a tree fragment of the expected `type`, throw an exception." @@ -86,6 +89,7 @@ (assert (suitable-fragment? tree-fragment type) (throw (Exception. (format "Expected a %s fragment" type))))) + (defn generate-rule "From this `tree`, assumed to be a syntactically correct rule specification, generate and return the appropriate rule as a function of two arguments." @@ -93,6 +97,7 @@ (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." @@ -100,21 +105,25 @@ (assert-type tree :CONDITIONS) (generate (nth tree 1))) + (defn generate-condition [tree] (assert-type tree :CONDITION) (generate (nth tree 1))) + (defn generate-conjunct-condition [tree] (assert-type tree :CONJUNCT-CONDITION) (list 'and (generate (nth tree 1))(generate (nth tree 3)))) + (defn generate-disjunct-condition [tree] (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] @@ -127,6 +136,7 @@ 'upper (list 'max l1 l2)] (list 'and (list '>= pv 'lower)(list '<= pv 'upper))))) + (defn generate-disjunct-property-condition "Generate a property condition where the expression is a disjunct expression. TODO: this is definitely still wrong!" @@ -141,10 +151,22 @@ (if (= qualifier '=) e (list 'not e)))))) + (defn generate-property-condition ([tree] (assert-type tree :PROPERTY-CONDITION) - (generate-property-condition tree (first (nth tree 3)))) + (if + (and (= (count tree) 2) (= (first (second tree)) :SYMBOL)) + ;; it's a shorthand for 'state equal to symbol'. This should probably have + ;; been handled in simplify... + (generate-property-condition + (list + :PROPERTY-CONDITION + '(:SYMBOL "state") + '(:QUALIFIER (:EQUIVALENCE (:EQUAL "equal to"))) + (second tree))) + ;; otherwise... + (generate-property-condition tree (first (nth tree 3))))) ([tree expression-type] (assert-type tree :PROPERTY-CONDITION) (let [property (generate (nth tree 1)) @@ -155,6 +177,7 @@ :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) @@ -164,11 +187,13 @@ (throw (Exception. reserved-properties-error)) (list 'merge 'cell {property expression})))) + (defn generate-multiple-actions [tree] (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") (conj 'do (map generate-simple-action (rest tree)))) + (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." @@ -178,6 +203,7 @@ (cons (generate (second tree)) (generate (nth tree 3))) (list (generate (second tree))))) + (defn generate-numeric-expression [tree] (assert-type tree :NUMERIC-EXPRESSION) @@ -185,58 +211,31 @@ :SYMBOL (list (keyword (second (second tree))) 'cell) (generate (second tree)))) + (defn generate-neighbours-condition "Generate code for a condition which refers to neighbours." ([tree] - (generate-neighbours-condition tree (first (second tree)))) + (assert-type tree :NEIGHBOURS-CONDITION) + (generate-neighbours-condition tree (first (second (second tree))))) ([tree quantifier-type] - (let [quantifier (second (second tree)) + (let [quantifier (second tree) pc (generate (nth tree 4))] (case quantifier-type - :NUMBER (generate-neighbours-condition '= (read-string quantifier) pc 1) + :NUMBER (generate-neighbours-condition '= (read-string (second (second quantifier))) pc 1) :SOME (generate-neighbours-condition '> 0 pc 1) - :QUANTIFIER - (let [comparative (generate (simplify (second quantifier))) - value (simplify (nth quantifier 5))] - (generate-neighbours-condition comparative value pc 1))))) + :MORE (let [value (generate (nth quantifier 3))] + (generate-neighbours-condition '> value pc 1)) + :LESS (let [value (generate (nth quantifier 3))] + (generate-neighbours-condition '< value pc 1))))) ([comp1 quantity property-condition distance] (list comp1 - (list 'count (list 'remove false (list 'map (list 'fn ['cell] property-condition) '(get-neighbours cell world distance)))) quantity)) + (list 'count + (list 'remove 'false? + (list 'map (list 'fn ['cell] property-condition) + (list 'mw-engine.utils/get-neighbours 'world 'cell distance)))) quantity)) ([comp1 quantity property-condition] (generate-neighbours-condition comp1 quantity property-condition 1))) -;; (def s1 "if 3 neighbours have state equal to forest then state should be forest") -;; (def s2 "if some neighbours have state equal to forest then state should be forest") -;; (def s3 "if more than 3 neighbours have state equal to forest then state should be forest") -;; (def s4 "if fewer than 3 neighbours have state equal to forest then state should be forest") -;; (def s5 "if all neighbours have state equal to forest then state should be forest") -;; (def s6 "if more than 3 neighbours within 2 have state equal to forest then state should be forest") - -;; (nth (simplify (parse-rule s1)) 2) -;; (second (nth (simplify (parse-rule s1)) 2)) -;; (nth (simplify (parse-rule s2)) 2) -;; (map simplify (nth (simplify (parse-rule s2)) 2)) -;; ;; (second (nth (simplify (parse-rule s2)) 2)) -;; ;; (nth (simplify (parse-rule s3)) 2) -;; (second (nth (simplify (parse-rule s3)) 2)) -;; (map simplify (second (nth (simplify (parse-rule s3)) 2))) -;; ;; (nth (simplify (parse-rule s4)) 2) -;; ;; (second (nth (simplify (parse-rule s4)) 2)) -;; ;; (nth (simplify (parse-rule s5)) 2) -;; ;; (second (nth (simplify (parse-rule s5)) 2)) -;; ;; (nth (simplify (parse-rule s6)) 2) -;; ;; (second (nth (simplify (parse-rule s6)) 2)) - -;; ;; (generate (nth (nth (simplify (parse-rule s5)) 2) 4)) -;; ;; (generate (nth (simplify (parse-rule s2)) 2)) -;; ;; (generate (nth (simplify (parse-rule s1)) 2)) - - -;; (generate-neighbours-condition '= 3 '(= (:state cell) :forest) 1) -;; (generate-neighbours-condition (nth (simplify (parse-rule s3)) 2)) -;; (generate-neighbours-condition (nth (simplify (parse-rule s2)) 2)) -;; (generate-neighbours-condition (nth (simplify (parse-rule s1)) 2)) - (defn generate "Generate code for this (fragment of a) parse tree" @@ -274,8 +273,6 @@ (map generate tree)) tree)) -(generate '(:PROPERTY-CONDITION (:SYMBOL "wolves") (:QUALIFIER (:COMPARATIVE-QUALIFIER (:IS "are") (:MORE "more") (:THAN "than"))) (:SYMBOL "deer"))) - (defn simplify-qualifier "Given that this `tree` fragment represents a qualifier, what @@ -315,12 +312,10 @@ :CONDITION (simplify-second-of-two tree) :CONDITIONS (simplify-second-of-two tree) :EXPRESSION (simplify-second-of-two tree) -;; :QUANTIFIER (simplify-second-of-two tree) - :NOT nil + :NOT nil ;; TODO is this right?!? It looks wrong :PROPERTY (simplify-second-of-two tree) :SPACE nil :THEN nil - ;; :QUALIFIER (simplify-qualifier tree) :VALUE (simplify-second-of-two tree) (remove nil? (map simplify tree))) tree)) @@ -332,7 +327,15 @@ (defn explain-parse-error-reason "Attempt to explain the reason for the parse error." [reason] - (str "Expecting one of (" (apply str (map #(str (:expecting %) " ") (first reason))) ")")) + (str "Expecting one of (" (apply str (map #(str (:expecting %) " ") reason)) ")")) + +(defn parser-error-to-map + [parser-error] + (let [m (reduce (fn [map item](merge map {(first item)(second item)})) {} parser-error) + reason (map + #(reduce (fn [map item] (merge {(first item) (second item)} map)) {} %) + (:reason m))] + (merge m {:reason reason}))) (defn throw-parse-exception "Construct a helpful error message from this `parser-error`, and throw an exception with that message." @@ -342,11 +345,11 @@ [ ;; the error structure is a list, such that each element is a list of two items, and ;; the first element in each sublist is a keyword. Easier to work with it as a map - error-map (reduce (fn [map item](merge map {(first item)(rest item)})) {} parser-error) - text (first (:text error-map)) + error-map (parser-error-to-map parser-error) + text (:text error-map) reason (explain-parse-error-reason (:reason error-map)) ;; rules have only one line, by definition; we're interested in the column - column (if (:column error-map)(first (:column error-map)) 0) + column (if (:column error-map)(: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) diff --git a/test/mw_parser/declarative_test.clj b/test/mw_parser/declarative_test.clj index b3eaed7..86cb449 100644 --- a/test/mw_parser/declarative_test.clj +++ b/test/mw_parser/declarative_test.clj @@ -1,7 +1,8 @@ (ns mw-parser.declarative-test (:use clojure.pprint mw-engine.core - mw-engine.world) + mw-engine.world + mw-engine.utils) (:require [clojure.test :refer :all] [mw-parser.declarative :refer :all])) @@ -103,8 +104,8 @@ (is (= (apply afn (list {:state :new} nil)) {:state :grassland}) "Rule fires when condition is met") - (is (nil? (apply afn (list {:state :forest} nil)))) - "Rule doesn't fire when condition isn't met")) + (is (nil? (apply afn (list {:state :forest} nil))) + "Rule doesn't fire when condition isn't met"))) (testing "Condition conjunction rule" (let [afn (compile-rule "if state is new and altitude is 0 then state should be water")] @@ -196,13 +197,13 @@ (is (nil? (apply afn (list {:altitude 10} nil))) "Rule does not fire when condition is not met"))) -;; (testing "Property is less than property" -;; (let [afn (compile-rule "if wolves are less than deer then deer should be deer - wolves")] -;; (is (= (apply afn (list {:deer 3 :wolves 2} nil)) -;; {:deer 1 :wolves 2}) -;; "Rule fires when condition is met") -;; (is (nil? (apply afn (list {:deer 2 :wolves 3} nil))) -;; "Rule does not fire when condition is not met"))) + (testing "Property is less than property" + (let [afn (compile-rule "if wolves are less than deer then deer should be deer - wolves")] + (is (= (apply afn (list {:deer 3 :wolves 2} nil)) + {:deer 1 :wolves 2}) + "Rule fires when condition is met") + (is (nil? (apply afn (list {:deer 2 :wolves 3} nil))) + "Rule does not fire when condition is not met"))) (testing "Number neighbours have property equal to value" (let [afn (compile-rule "if 3 neighbours have state equal to new then state should be water") @@ -214,7 +215,15 @@ "Middle cell has eight neighbours, so rule does not fire.")) (let [afn (compile-rule "if 3 neighbours are new then state should be water") world (make-world 3 3)] - ;; 'are new' should be the same as 'have state equal to new' + ;; 'are new' and 'is new' should be the same as 'have state equal to new' + (is (= (apply afn (list {:x 0 :y 0} world)) + {:state :water :x 0 :y 0}) + "Rule fires when condition is met (in a new world all cells are new, corner cell has three neighbours)") + (is (nil? (apply afn (list {:x 1 :y 1} world))) + "Middle cell has eight neighbours, so rule does not fire.")) + (let [afn (compile-rule "if 3 neighbours is new then state should be water") + world (make-world 3 3)] + ;; 'are new' and 'is new' should be the same as 'have state equal to new' (is (= (apply afn (list {:x 0 :y 0} world)) {:state :water :x 0 :y 0}) "Rule fires when condition is met (in a new world all cells are new, corner cell has three neighbours)")