From 1c6ceb899c013da8d26052e71e49626d39bdae08 Mon Sep 17 00:00:00 2001 From: simon Date: Wed, 10 Aug 2016 13:30:15 +0100 Subject: [PATCH 1/9] Substantially closer to the declarative parser fully working, but not yet perfect. --- src/mw_parser/declarative.clj | 19 +- test/mw_parser/declarative_test.clj | 674 ++++++++++++++-------------- 2 files changed, 353 insertions(+), 340 deletions(-) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index 8bea7dd..1624446 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -11,7 +11,7 @@ ;; (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 bad-parse-error "I did not understand:\n '%s'\n %s\n %s") (def grammar @@ -171,7 +171,11 @@ (assert-type tree :PROPERTY-CONDITION) (let [property (generate (nth tree 1)) qualifier (generate (nth tree 2)) - expression (generate (nth tree 3))] + e (generate (nth tree 3)) + expression (cond + (and (not (= qualifier '=)) (keyword? e)) (list 'or (list e 'cell) e) + (and (not (= qualifier 'not=)) (keyword? e)) (list 'or (list e 'cell) e) + :else e)] (case expression-type :DISJUNCT-EXPRESSION (generate-disjunct-property-condition tree property qualifier expression) :RANGE-EXPRESSION (generate-ranged-property-condition tree property expression) @@ -207,9 +211,13 @@ (defn generate-numeric-expression [tree] (assert-type tree :NUMERIC-EXPRESSION) - (case (first (second tree)) - :SYMBOL (list (keyword (second (second tree))) 'cell) - (generate (second tree)))) + (case (count tree) + 4 (let [[p operator expression] (rest tree) + property (if (number? p) p (list p 'cell))] + (list (generate operator) (generate property) (generate expression))) + (case (first (second tree)) + :SYMBOL (list (keyword (second (second tree))) 'cell) + (generate (second tree))))) (defn generate-neighbours-condition @@ -270,6 +278,7 @@ :SIMPLE-ACTION (generate-simple-action tree) :SYMBOL (keyword (second tree)) :VALUE (generate (second tree)) + :OPERATOR (symbol (second tree)) (map generate tree)) tree)) diff --git a/test/mw_parser/declarative_test.clj b/test/mw_parser/declarative_test.clj index 86cb449..1e8e451 100644 --- a/test/mw_parser/declarative_test.clj +++ b/test/mw_parser/declarative_test.clj @@ -39,6 +39,10 @@ '(:sealevel cell)) )) +(deftest comparative-tests + (testing "Parsing comparatives." + )) + (deftest lhs-generators-tests (testing "Generating left-hand-side fragments of rule functions from appropriate fragments of parse trees" (is (generate @@ -100,418 +104,418 @@ ;; 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"))) + (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"))) + (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"))) + (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"))) + (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? + (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 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'")) + "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"))) + (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"))) + (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"))) + (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"))) -;; 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 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"))) + (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"))) + (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' 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)") - (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 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' 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)") + (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."))) + ;; if 3 neighbours have altitude more than 10 then state should be beach + (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."))) + (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."))) + (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.")) - ) + (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."))) + (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."))) + (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 + ;; 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."))) + (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."))) + (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 + ;; 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."))) + (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 + ;; 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."))) + (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 + ;; 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."))) + (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 + ;; 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."))) + (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 + ;; 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."))) + (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 + ;; 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."))) + (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 + ;; '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"))) + (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 + ;; 'property should be symbolic-value' and 'property should be numeric-value' + ;; already tested in tests above -;; number chance in number property should be value + ;; 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"))) + (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 + ;; 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"))) + (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"))) + (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"))) + (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"))) + (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"))) + (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"))) + (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"))) + (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"))) + (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 + ;; 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."))) + (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 + ;; 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.")) + (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 9836cbff5060f8f44ed64dd3bbd6babda2bf7f9a Mon Sep 17 00:00:00 2001 From: simon Date: Wed, 10 Aug 2016 19:23:16 +0100 Subject: [PATCH 2/9] All tests pass. I should now be able to ditch the old parser and use the new, but first I want to do some major code restructuring. --- src/mw_parser/declarative.clj | 156 +++++++++++++++++++++------- test/mw_parser/declarative_test.clj | 4 +- 2 files changed, 123 insertions(+), 37 deletions(-) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index 1624446..baa9ab5 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -18,12 +18,13 @@ ;; 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 ; + CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | CONDITION ; DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS; CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS; - 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; + CONDITION := WITHIN-CONDITION | NEIGHBOURS-CONDITION | PROPERTY-CONDITION; + WITHIN-CONDITION := QUANTIFIER SPACE NEIGHBOURS SPACE WITHIN SPACE NUMBER SPACE IS SPACE PROPERTY-CONDITION-OR-EXPRESSION; + NEIGHBOURS-CONDITION := QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUALIFIER SPACE NEIGHBOURS-CONDITION; + PROPERTY-CONDITION-OR-EXPRESSION := PROPERTY-CONDITION | 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; @@ -31,7 +32,7 @@ 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; - COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN; + COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN | COMPARATIVE SPACE THAN; QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER; QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER; EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; @@ -59,12 +60,13 @@ IS := 'is' | 'are' | 'have' | 'has'; NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+'; SYMBOL := #'[a-z]+'; - ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS + 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 BECOMES SPACE EXPRESSION - BECOMES := 'should be' - SPACE := #' *'" + PROBABLE-ACTION := VALUE SPACE CHANCE-IN SPACE VALUE SPACE SIMPLE-ACTION; + SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION; + CHANCE-IN := 'chance in'; + BECOMES := 'should be' | 'becomes'; + SPACE := #' *'"; ) (defn TODO @@ -73,7 +75,7 @@ message) -(declare generate simplify) +(declare generate generate-action simplify) (defn suitable-fragment? @@ -90,6 +92,18 @@ (throw (Exception. (format "Expected a %s fragment" type))))) +(defn search-tree + "Return the first element of this tree which has this tag in a depth-first, left-to-right search" + [tree tag] + (cond + (= (first tree) tag) tree + :else (first + (remove nil? + (map + #(search-tree % tag) + (rest tree)))))) + + (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." @@ -103,25 +117,25 @@ generate and return the appropriate clojure fragment." [tree] (assert-type tree :CONDITIONS) - (generate (nth tree 1))) + (generate (second tree))) (defn generate-condition [tree] (assert-type tree :CONDITION) - (generate (nth tree 1))) + (generate (second tree))) (defn generate-conjunct-condition [tree] (assert-type tree :CONJUNCT-CONDITION) - (list 'and (generate (nth tree 1))(generate (nth tree 3)))) + (cons 'and (map generate (rest tree)))) (defn generate-disjunct-condition [tree] (assert-type tree :DISJUNCT-CONDITION) - (list 'or (generate (nth tree 1))(generate (nth tree 3)))) + (cons 'or (map generate (rest tree)))) (defn generate-ranged-property-condition @@ -141,7 +155,7 @@ "Generate a property condition where the expression is a disjunct expression. TODO: this is definitely still wrong!" ([tree] - (let [property (generate (nth tree 1)) + (let [property (generate (second tree)) qualifier (generate (nth tree 2)) expression (generate (nth tree 3))] (generate-disjunct-property-condition tree property qualifier expression))) @@ -169,7 +183,7 @@ (generate-property-condition tree (first (nth tree 3))))) ([tree expression-type] (assert-type tree :PROPERTY-CONDITION) - (let [property (generate (nth tree 1)) + (let [property (generate (second tree)) qualifier (generate (nth tree 2)) e (generate (nth tree 3)) expression (cond @@ -182,21 +196,61 @@ (list qualifier (list property 'cell) expression))))) -(defn generate-simple-action +(defn generate-qualifier [tree] - (assert-type tree :SIMPLE-ACTION) - (let [property (generate (nth tree 1)) - expression (generate (nth tree 3))] - (if (or (= property :x) (= property :y)) - (throw (Exception. reserved-properties-error)) - (list 'merge 'cell {property expression})))) + (if + (= (count tree) 2) + (generate (second tree)) + ;; else + (generate (nth tree 2)))) + + +(defn generate-simple-action + ([tree] + (assert-type tree :SIMPLE-ACTION) + (generate-simple-action tree [])) + ([tree others] + (assert-type tree :SIMPLE-ACTION) + (let [property (generate (second tree)) + expression (generate (nth tree 3))] + (if (or (= property :x) (= property :y)) + (throw (Exception. reserved-properties-error)) + (list 'merge + (if (empty? others) 'cell + ;; else + (generate others)) + {property expression}))))) + + +(defn generate-probable-action + ([tree] + (assert-type tree :PROBABLE-ACTION) + (generate-probable-action tree [])) + ([tree others] + (assert-type tree :PROBABLE-ACTION) + (let + [chances (generate (nth tree 1)) + total (generate (nth tree 2)) + action (generate-action (nth tree 3) others)] + ;; TODO: could almost certainly be done better with macro syntax + (list 'if + (list '< (list 'rand total) chances) + action)))) + + +(defn generate-action + [tree others] + (case (first tree) + :ACTIONS (generate-action (first tree) others) + :SIMPLE-ACTION (generate-simple-action tree others) + :PROBABLE-ACTION (generate-probable-action tree others) + (throw (Exception. (str "Not a known action type: " (first tree)))))) (defn generate-multiple-actions [tree] - (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") - (conj 'do (map generate-simple-action (rest tree)))) - + (assert-type tree :ACTIONS) + (generate-action (first (rest tree)) (second (rest tree)))) (defn generate-disjunct-value "Generate a disjunct value. Essentially what we need here is to generate a @@ -224,7 +278,9 @@ "Generate code for a condition which refers to neighbours." ([tree] (assert-type tree :NEIGHBOURS-CONDITION) - (generate-neighbours-condition tree (first (second (second tree))))) + (case (first (second tree)) + :QUANTIFIER (generate-neighbours-condition tree (first (second (second tree)))) + :QUALIFIER (cons (generate (second tree)) (rest (generate (nth tree 2)))))) ([tree quantifier-type] (let [quantifier (second tree) pc (generate (nth tree 4))] @@ -234,7 +290,8 @@ :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))))) + (generate-neighbours-condition '< value pc 1)) + ))) ([comp1 quantity property-condition distance] (list comp1 (list 'count @@ -245,6 +302,31 @@ (generate-neighbours-condition comp1 quantity property-condition 1))) +(defn generate-within-condition + "Generate code for a condition which refers to neighbours within a specified distance. + NOTE THAT there's clearly masses of commonality between this and + `generate-neighbours-condition`, and that some refactoring is almost certainly + desirable. It may be that it's better to simplify a `NEIGHBOURS-CONDITION` + into a `WITHIN-CONDITION` in the simplification stage." + ([tree] + (assert-type tree :WITHIN-CONDITION) + (case (first (second tree)) + :QUANTIFIER (generate-within-condition tree (first (second (second tree)))) + :QUALIFIER (TODO "qualified within... help!"))) + ([tree quantifier-type] + (let [quantifier (second tree) + distance (generate (nth tree 4)) + pc (generate (nth tree 6))] + (case quantifier-type + :NUMBER (generate-neighbours-condition '= (read-string (second (second quantifier))) pc distance) + :SOME (generate-neighbours-condition '> 0 pc distance) + :MORE (let [value (generate (nth quantifier 3))] + (generate-neighbours-condition '> value pc distance)) + :LESS (let [value (generate (nth quantifier 3))] + (generate-neighbours-condition '< value pc distance)) + )))) + + (defn generate "Generate code for this (fragment of a) parse tree" [tree] @@ -253,7 +335,7 @@ (case (first tree) :ACTIONS (generate-multiple-actions tree) :COMPARATIVE (generate (second tree)) - :COMPARATIVE-QUALIFIER (generate (nth tree 2)) + :COMPARATIVE-QUALIFIER (generate (second tree)) :CONDITION (generate-condition tree) :CONDITIONS (generate-conditions tree) :CONJUNCT-CONDITION (generate-conjunct-condition tree) @@ -271,14 +353,16 @@ :NEIGHBOURS-CONDITION (generate-neighbours-condition tree) :NUMERIC-EXPRESSION (generate-numeric-expression tree) :NUMBER (read-string (second tree)) + :OPERATOR (symbol (second tree)) + :PROBABLE-ACTION (generate-probable-action tree) :PROPERTY (list (generate (second tree)) 'cell) ;; dubious - may not be right :PROPERTY-CONDITION (generate-property-condition tree) - :QUALIFIER (generate (second tree)) + :QUALIFIER (generate-qualifier tree) :RULE (generate-rule tree) :SIMPLE-ACTION (generate-simple-action tree) :SYMBOL (keyword (second tree)) :VALUE (generate (second tree)) - :OPERATOR (symbol (second tree)) + :WITHIN-CONDITION (generate-within-condition tree) (map generate tree)) tree)) @@ -300,7 +384,7 @@ "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)) + (if (= (count tree) 2) (simplify (second tree)) tree)) (defn rule? @@ -316,15 +400,17 @@ (coll? tree) (case (first tree) :ACTION (simplify-second-of-two tree) - :ACTIONS (simplify-second-of-two tree) + :ACTIONS (cons (first tree) (simplify (rest tree))) + :CHANCE-IN nil :COMPARATIVE (simplify-second-of-two tree) :CONDITION (simplify-second-of-two tree) :CONDITIONS (simplify-second-of-two tree) :EXPRESSION (simplify-second-of-two tree) - :NOT nil ;; TODO is this right?!? It looks wrong :PROPERTY (simplify-second-of-two tree) + :PROPERTY-CONDITION-OR-EXPRESSION (simplify-second-of-two tree) :SPACE nil :THEN nil + :AND nil :VALUE (simplify-second-of-two tree) (remove nil? (map simplify tree))) tree)) diff --git a/test/mw_parser/declarative_test.clj b/test/mw_parser/declarative_test.clj index 1e8e451..38365ee 100644 --- a/test/mw_parser/declarative_test.clj +++ b/test/mw_parser/declarative_test.clj @@ -436,12 +436,12 @@ "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")] + (let [afn (compile-rule "if state is climax then fertility should be fertility + leaffall")] (is (= (:fertility (apply afn (list {:state :climax :fertility 0 - :leaf-fall 1} nil))) + :leaffall 1} nil))) 1) "Addition is executed"))) From d2a73ba40865fc654579816b4f6df7924b7b1271 Mon Sep 17 00:00:00 2001 From: simon Date: Wed, 10 Aug 2016 20:11:17 +0100 Subject: [PATCH 3/9] Major restructuring, switched over to use the new declarative parser. Some rules in the bulk test file no longer parse, but all rules in the demonstration rule-sets do. --- src/mw_parser/bulk.clj | 2 +- src/mw_parser/declarative.clj | 418 ++-------------------------- src/mw_parser/errors.clj | 45 +++ src/mw_parser/generate.clj | 270 ++++++++++++++++++ src/mw_parser/simplify.clj | 48 ++++ src/mw_parser/utils.clj | 39 +++ test/mw_parser/declarative_test.clj | 53 +--- test/mw_parser/generate_test.clj | 57 ++++ 8 files changed, 488 insertions(+), 444 deletions(-) create mode 100644 src/mw_parser/errors.clj create mode 100644 src/mw_parser/generate.clj create mode 100644 src/mw_parser/simplify.clj create mode 100644 src/mw_parser/utils.clj create mode 100644 test/mw_parser/generate_test.clj diff --git a/src/mw_parser/bulk.clj b/src/mw_parser/bulk.clj index b4674ec..00ecd14 100644 --- a/src/mw_parser/bulk.clj +++ b/src/mw_parser/bulk.clj @@ -2,7 +2,7 @@ ;; objective is to parse rules out of a block of text from a textarea (ns mw-parser.bulk - (:use mw-parser.core + (:use mw-parser.declarative mw-engine.utils clojure.java.io [clojure.string :only [split trim]]) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index baa9ab5..69792a4 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -1,19 +1,13 @@ (ns mw-parser.declarative (:use mw-engine.utils + mw-parser.utils + [mw-parser.errors :as pe] + [mw-parser.generate :as pg] + [mw-parser.simplify :as ps] [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 ;; TOKENS within the parser should be unambiguous @@ -69,395 +63,33 @@ SPACE := #' *'"; ) -(defn TODO - "Marker to indicate I'm not yet finished!" - [message] - message) - - -(declare generate generate-action 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 search-tree - "Return the first element of this tree which has this tag in a depth-first, left-to-right search" - [tree tag] - (cond - (= (first tree) tag) tree - :else (first - (remove nil? - (map - #(search-tree % tag) - (rest tree)))))) - - -(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] - (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 (second tree))) - - -(defn generate-condition - [tree] - (assert-type tree :CONDITION) - (generate (second tree))) - - -(defn generate-conjunct-condition - [tree] - (assert-type tree :CONJUNCT-CONDITION) - (cons 'and (map generate (rest tree)))) - - -(defn generate-disjunct-condition - [tree] - (assert-type tree :DISJUNCT-CONDITION) - (cons 'or (map generate (rest tree)))) - - -(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-disjunct-property-condition - "Generate a property condition where the expression is a disjunct expression. - TODO: this is definitely still wrong!" - ([tree] - (let [property (generate (second tree)) - 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] - (assert-type tree :PROPERTY-CONDITION) - (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 (second tree)) - qualifier (generate (nth tree 2)) - e (generate (nth tree 3)) - expression (cond - (and (not (= qualifier '=)) (keyword? e)) (list 'or (list e 'cell) e) - (and (not (= qualifier 'not=)) (keyword? e)) (list 'or (list e 'cell) e) - :else e)] - (case expression-type - :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))))) - - -(defn generate-qualifier - [tree] - (if - (= (count tree) 2) - (generate (second tree)) - ;; else - (generate (nth tree 2)))) - - -(defn generate-simple-action - ([tree] - (assert-type tree :SIMPLE-ACTION) - (generate-simple-action tree [])) - ([tree others] - (assert-type tree :SIMPLE-ACTION) - (let [property (generate (second tree)) - expression (generate (nth tree 3))] - (if (or (= property :x) (= property :y)) - (throw (Exception. reserved-properties-error)) - (list 'merge - (if (empty? others) 'cell - ;; else - (generate others)) - {property expression}))))) - - -(defn generate-probable-action - ([tree] - (assert-type tree :PROBABLE-ACTION) - (generate-probable-action tree [])) - ([tree others] - (assert-type tree :PROBABLE-ACTION) - (let - [chances (generate (nth tree 1)) - total (generate (nth tree 2)) - action (generate-action (nth tree 3) others)] - ;; TODO: could almost certainly be done better with macro syntax - (list 'if - (list '< (list 'rand total) chances) - action)))) - - -(defn generate-action - [tree others] - (case (first tree) - :ACTIONS (generate-action (first tree) others) - :SIMPLE-ACTION (generate-simple-action tree others) - :PROBABLE-ACTION (generate-probable-action tree others) - (throw (Exception. (str "Not a known action type: " (first tree)))))) - - -(defn generate-multiple-actions - [tree] - (assert-type tree :ACTIONS) - (generate-action (first (rest tree)) (second (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." - [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 (count tree) - 4 (let [[p operator expression] (rest tree) - property (if (number? p) p (list p 'cell))] - (list (generate operator) (generate property) (generate expression))) - (case (first (second tree)) - :SYMBOL (list (keyword (second (second tree))) 'cell) - (generate (second tree))))) - - -(defn generate-neighbours-condition - "Generate code for a condition which refers to neighbours." - ([tree] - (assert-type tree :NEIGHBOURS-CONDITION) - (case (first (second tree)) - :QUANTIFIER (generate-neighbours-condition tree (first (second (second tree)))) - :QUALIFIER (cons (generate (second tree)) (rest (generate (nth tree 2)))))) - ([tree quantifier-type] - (let [quantifier (second tree) - pc (generate (nth tree 4))] - (case quantifier-type - :NUMBER (generate-neighbours-condition '= (read-string (second (second quantifier))) pc 1) - :SOME (generate-neighbours-condition '> 0 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) - (list 'mw-engine.utils/get-neighbours 'world 'cell distance)))) quantity)) - ([comp1 quantity property-condition] - (generate-neighbours-condition comp1 quantity property-condition 1))) - - -(defn generate-within-condition - "Generate code for a condition which refers to neighbours within a specified distance. - NOTE THAT there's clearly masses of commonality between this and - `generate-neighbours-condition`, and that some refactoring is almost certainly - desirable. It may be that it's better to simplify a `NEIGHBOURS-CONDITION` - into a `WITHIN-CONDITION` in the simplification stage." - ([tree] - (assert-type tree :WITHIN-CONDITION) - (case (first (second tree)) - :QUANTIFIER (generate-within-condition tree (first (second (second tree)))) - :QUALIFIER (TODO "qualified within... help!"))) - ([tree quantifier-type] - (let [quantifier (second tree) - distance (generate (nth tree 4)) - pc (generate (nth tree 6))] - (case quantifier-type - :NUMBER (generate-neighbours-condition '= (read-string (second (second quantifier))) pc distance) - :SOME (generate-neighbours-condition '> 0 pc distance) - :MORE (let [value (generate (nth quantifier 3))] - (generate-neighbours-condition '> value pc distance)) - :LESS (let [value (generate (nth quantifier 3))] - (generate-neighbours-condition '< value pc distance)) - )))) - - -(defn generate - "Generate code for this (fragment of a) parse tree" - [tree] - (if - (coll? tree) - (case (first tree) - :ACTIONS (generate-multiple-actions tree) - :COMPARATIVE (generate (second tree)) - :COMPARATIVE-QUALIFIER (generate (second tree)) - :CONDITION (generate-condition tree) - :CONDITIONS (generate-conditions tree) - :CONJUNCT-CONDITION (generate-conjunct-condition tree) - :DISJUNCT-CONDITION (generate-disjunct-condition tree) - :DISJUNCT-EXPRESSION (generate (nth tree 2)) - :DISJUNCT-VALUE (generate-disjunct-value tree) - :EQUIVALENCE '= - :EXPRESSION (generate (second tree)) - :LESS '< - :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)) - :OPERATOR (symbol (second tree)) - :PROBABLE-ACTION (generate-probable-action tree) - :PROPERTY (list (generate (second tree)) 'cell) ;; dubious - may not be right - :PROPERTY-CONDITION (generate-property-condition tree) - :QUALIFIER (generate-qualifier tree) - :RULE (generate-rule tree) - :SIMPLE-ACTION (generate-simple-action tree) - :SYMBOL (keyword (second tree)) - :VALUE (generate (second tree)) - :WITHIN-CONDITION (generate-within-condition tree) - (map generate tree)) - tree)) - - -(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 (second tree)) 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 - (coll? tree) - (case (first tree) - :ACTION (simplify-second-of-two tree) - :ACTIONS (cons (first tree) (simplify (rest tree))) - :CHANCE-IN nil - :COMPARATIVE (simplify-second-of-two tree) - :CONDITION (simplify-second-of-two tree) - :CONDITIONS (simplify-second-of-two tree) - :EXPRESSION (simplify-second-of-two tree) - :PROPERTY (simplify-second-of-two tree) - :PROPERTY-CONDITION-OR-EXPRESSION (simplify-second-of-two tree) - :SPACE nil - :THEN nil - :AND nil - :VALUE (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 - "Attempt to explain the reason for the parse error." - [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." - [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 (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)(: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. 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 (simplify (parse-rule rule))] - (if (rule? tree) (eval (generate tree)) - (throw-parse-exception tree)))) + "Parse this `rule-text`, a string conforming to the grammar of MicroWorld rules, + into Clojure source, and then compile it into an anonymous + function object, getting round the problem of binding mw-engine.utils in + the compiling environment. If `return-tuple?` is present and true, return + a list comprising the anonymous function compiled, and the function from + which it was compiled. + + Throws an exception if parsing fails." + ([rule-text return-tuple?] + (assert (string? rule-text)) + (let [rule (trim rule-text) + tree (ps/simplify (parse-rule rule)) + afn (if (rule? tree) (eval (pg/generate tree)) + ;; else + (pe/throw-parse-exception tree))] + (if return-tuple? + (list afn rule) + ;; else + afn))) + ([rule-text] + (compile-rule rule-text false))) diff --git a/src/mw_parser/errors.clj b/src/mw_parser/errors.clj new file mode 100644 index 0000000..8db5f6c --- /dev/null +++ b/src/mw_parser/errors.clj @@ -0,0 +1,45 @@ +(ns mw-parser.errors) + +;; 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") + + +(defn- explain-parse-error-reason + "Attempt to explain the reason for the parse error." + [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." + [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 (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)(: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. message)))) diff --git a/src/mw_parser/generate.clj b/src/mw_parser/generate.clj new file mode 100644 index 0000000..d27647d --- /dev/null +++ b/src/mw_parser/generate.clj @@ -0,0 +1,270 @@ +(ns mw-parser.generate + (:use mw-engine.utils + mw-parser.utils + [mw-parser.errors :as pe])) + + +(declare generate generate-action) + + +(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] + (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 (second tree))) + + +(defn generate-condition + [tree] + (assert-type tree :CONDITION) + (generate (second tree))) + + +(defn generate-conjunct-condition + [tree] + (assert-type tree :CONJUNCT-CONDITION) + (cons 'and (map generate (rest tree)))) + + +(defn generate-disjunct-condition + [tree] + (assert-type tree :DISJUNCT-CONDITION) + (cons 'or (map generate (rest tree)))) + + +(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-disjunct-property-condition + "Generate a property condition where the expression is a disjunct expression. + TODO: this is definitely still wrong!" + ([tree] + (let [property (generate (second tree)) + 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] + (assert-type tree :PROPERTY-CONDITION) + (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 (second tree)) + qualifier (generate (nth tree 2)) + e (generate (nth tree 3)) + expression (cond + (and (not (= qualifier '=)) (keyword? e)) (list 'or (list e 'cell) e) + (and (not (= qualifier 'not=)) (keyword? e)) (list 'or (list e 'cell) e) + :else e)] + (case expression-type + :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))))) + + +(defn generate-qualifier + [tree] + (if + (= (count tree) 2) + (generate (second tree)) + ;; else + (generate (nth tree 2)))) + + +(defn generate-simple-action + ([tree] + (assert-type tree :SIMPLE-ACTION) + (generate-simple-action tree [])) + ([tree others] + (assert-type tree :SIMPLE-ACTION) + (let [property (generate (second tree)) + expression (generate (nth tree 3))] + (if (or (= property :x) (= property :y)) + (throw (Exception. pe/reserved-properties-error)) + (list 'merge + (if (empty? others) 'cell + ;; else + (generate others)) + {property expression}))))) + + +(defn generate-probable-action + ([tree] + (assert-type tree :PROBABLE-ACTION) + (generate-probable-action tree [])) + ([tree others] + (assert-type tree :PROBABLE-ACTION) + (let + [chances (generate (nth tree 1)) + total (generate (nth tree 2)) + action (generate-action (nth tree 3) others)] + ;; TODO: could almost certainly be done better with macro syntax + (list 'if + (list '< (list 'rand total) chances) + action)))) + + +(defn generate-action + [tree others] + (case (first tree) + :ACTIONS (generate-action (first tree) others) + :SIMPLE-ACTION (generate-simple-action tree others) + :PROBABLE-ACTION (generate-probable-action tree others) + (throw (Exception. (str "Not a known action type: " (first tree)))))) + + +(defn generate-multiple-actions + [tree] + (assert-type tree :ACTIONS) + (generate-action (first (rest tree)) (second (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." + [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 (count tree) + 4 (let [[p operator expression] (rest tree) + property (if (number? p) p (list p 'cell))] + (list (generate operator) (generate property) (generate expression))) + (case (first (second tree)) + :SYMBOL (list (keyword (second (second tree))) 'cell) + (generate (second tree))))) + + +(defn generate-neighbours-condition + "Generate code for a condition which refers to neighbours." + ([tree] + (assert-type tree :NEIGHBOURS-CONDITION) + (case (first (second tree)) + :QUANTIFIER (generate-neighbours-condition tree (first (second (second tree)))) + :QUALIFIER (cons (generate (second tree)) (rest (generate (nth tree 2)))))) + ([tree quantifier-type] + (let [quantifier (second tree) + pc (generate (nth tree 4))] + (case quantifier-type + :NUMBER (generate-neighbours-condition '= (read-string (second (second quantifier))) pc 1) + :SOME (generate-neighbours-condition '> 0 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) + (list 'mw-engine.utils/get-neighbours 'world 'cell distance)))) quantity)) + ([comp1 quantity property-condition] + (generate-neighbours-condition comp1 quantity property-condition 1))) + + +(defn generate-within-condition + "Generate code for a condition which refers to neighbours within a specified distance. + NOTE THAT there's clearly masses of commonality between this and + `generate-neighbours-condition`, and that some refactoring is almost certainly + desirable. It may be that it's better to simplify a `NEIGHBOURS-CONDITION` + into a `WITHIN-CONDITION` in the simplification stage." + ([tree] + (assert-type tree :WITHIN-CONDITION) + (case (first (second tree)) + :QUANTIFIER (generate-within-condition tree (first (second (second tree)))) + :QUALIFIER (TODO "qualified within... help!"))) + ([tree quantifier-type] + (let [quantifier (second tree) + distance (generate (nth tree 4)) + pc (generate (nth tree 6))] + (case quantifier-type + :NUMBER (generate-neighbours-condition '= (read-string (second (second quantifier))) pc distance) + :SOME (generate-neighbours-condition '> 0 pc distance) + :MORE (let [value (generate (nth quantifier 3))] + (generate-neighbours-condition '> value pc distance)) + :LESS (let [value (generate (nth quantifier 3))] + (generate-neighbours-condition '< value pc distance)) + )))) + + +(defn generate + "Generate code for this (fragment of a) parse tree" + [tree] + (if + (coll? tree) + (case (first tree) + :ACTIONS (generate-multiple-actions tree) + :COMPARATIVE (generate (second tree)) + :COMPARATIVE-QUALIFIER (generate (second tree)) + :CONDITION (generate-condition tree) + :CONDITIONS (generate-conditions tree) + :CONJUNCT-CONDITION (generate-conjunct-condition tree) + :DISJUNCT-CONDITION (generate-disjunct-condition tree) + :DISJUNCT-EXPRESSION (generate (nth tree 2)) + :DISJUNCT-VALUE (generate-disjunct-value tree) + :EQUIVALENCE '= + :EXPRESSION (generate (second tree)) + :LESS '< + :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)) + :OPERATOR (symbol (second tree)) + :PROBABLE-ACTION (generate-probable-action tree) + :PROPERTY (list (generate (second tree)) 'cell) ;; dubious - may not be right + :PROPERTY-CONDITION (generate-property-condition tree) + :QUALIFIER (generate-qualifier tree) + :RULE (generate-rule tree) + :SIMPLE-ACTION (generate-simple-action tree) + :SYMBOL (keyword (second tree)) + :VALUE (generate (second tree)) + :WITHIN-CONDITION (generate-within-condition tree) + (map generate tree)) + tree)) diff --git a/src/mw_parser/simplify.clj b/src/mw_parser/simplify.clj new file mode 100644 index 0000000..3ac2c3c --- /dev/null +++ b/src/mw_parser/simplify.clj @@ -0,0 +1,48 @@ +(ns mw-parser.simplify + (:use mw-engine.utils + mw-parser.utils)) + +(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 (second tree)) tree)) + + +(defn simplify + "Simplify/canonicalise this `tree`. Opportunistically replace complex fragments with + semantically identical simpler fragments" + [tree] + (if + (coll? tree) + (case (first tree) + :ACTION (simplify-second-of-two tree) + :ACTIONS (cons (first tree) (simplify (rest tree))) + :CHANCE-IN nil + :COMPARATIVE (simplify-second-of-two tree) + :CONDITION (simplify-second-of-two tree) + :CONDITIONS (simplify-second-of-two tree) + :EXPRESSION (simplify-second-of-two tree) + :PROPERTY (simplify-second-of-two tree) + :PROPERTY-CONDITION-OR-EXPRESSION (simplify-second-of-two tree) + :SPACE nil + :THEN nil + :AND nil + :VALUE (simplify-second-of-two tree) + (remove nil? (map simplify tree))) + tree)) diff --git a/src/mw_parser/utils.clj b/src/mw_parser/utils.clj new file mode 100644 index 0000000..14e91c5 --- /dev/null +++ b/src/mw_parser/utils.clj @@ -0,0 +1,39 @@ +(ns mw-parser.utils) + + +(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 TODO + "Marker to indicate I'm not yet finished!" + [message] + message) + + +(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 search-tree + "Return the first element of this tree which has this tag in a depth-first, left-to-right search" + [tree tag] + (cond + (= (first tree) tag) tree + :else (first + (remove nil? + (map + #(search-tree % tag) + (rest tree)))))) diff --git a/test/mw_parser/declarative_test.clj b/test/mw_parser/declarative_test.clj index 38365ee..93ffdbb 100644 --- a/test/mw_parser/declarative_test.clj +++ b/test/mw_parser/declarative_test.clj @@ -2,7 +2,8 @@ (:use clojure.pprint mw-engine.core mw-engine.world - mw-engine.utils) + mw-engine.utils + mw-parser.utils) (:require [clojure.test :refer :all] [mw-parser.declarative :refer :all])) @@ -32,55 +33,6 @@ (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 comparative-tests - (testing "Parsing comparatives." - )) - -(deftest lhs-generators-tests - (testing "Generating left-hand-side fragments of rule functions from appropriate fragments of parse trees" - (is (generate - '(:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest"))) - '(= (:state cell) :forest)) - (is (generate - '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:EQUIVALENCE [:IS "is"]] (:NUMBER "10"))) - '(= (:fertility cell) 10)) - (is (generate '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:COMPARATIVE [:LESS "less"]] (:NUMBER "10"))) - '(< (:fertility cell) 10)) - (is (generate '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:COMPARATIVE [:MORE "more"]] (:NUMBER "10"))) - '(> (:fertility cell) 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 (: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 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 (: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" @@ -100,6 +52,7 @@ "Exception thrown on attempt to set 'y'") )) + (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. diff --git a/test/mw_parser/generate_test.clj b/test/mw_parser/generate_test.clj new file mode 100644 index 0000000..eacd48c --- /dev/null +++ b/test/mw_parser/generate_test.clj @@ -0,0 +1,57 @@ +(ns mw-parser.generate-test + (:use clojure.pprint + mw-engine.core + mw-engine.world + mw-engine.utils + mw-parser.utils) + (:require [clojure.test :refer :all] + [mw-parser.generate :refer :all])) + + +(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 (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest"))) + '(= (:state cell) :forest)) + (is (generate + '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:EQUIVALENCE [:IS "is"]] (:NUMBER "10"))) + '(= (:fertility cell) 10)) + (is (generate '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:COMPARATIVE [:LESS "less"]] (:NUMBER "10"))) + '(< (:fertility cell) 10)) + (is (generate '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:COMPARATIVE [:MORE "more"]] (:NUMBER "10"))) + '(> (:fertility cell) 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 (: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 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 (: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})))) + )) From 3168c1b2fb718e9a939025060355e890696b13e4 Mon Sep 17 00:00:00 2001 From: simon Date: Sat, 13 Aug 2016 19:45:43 +0100 Subject: [PATCH 4/9] Trying to get code quality up, but in the process I've broken something - I think, the simplifier. --- src/mw_parser/bulk.clj | 27 +++++- src/mw_parser/core.clj | 145 ++++++++++++++++------------ src/mw_parser/declarative.clj | 45 +++++++-- src/mw_parser/errors.clj | 25 ++++- src/mw_parser/generate.clj | 56 ++++++++++- src/mw_parser/simplifier.clj | 92 ------------------ src/mw_parser/simplify.clj | 56 ++++++++--- src/mw_parser/utils.clj | 23 ++++- test/mw_parser/declarative_test.clj | 12 +++ 9 files changed, 298 insertions(+), 183 deletions(-) delete mode 100644 src/mw_parser/simplifier.clj diff --git a/src/mw_parser/bulk.clj b/src/mw_parser/bulk.clj index 00ecd14..2aba74c 100644 --- a/src/mw_parser/bulk.clj +++ b/src/mw_parser/bulk.clj @@ -1,13 +1,32 @@ -;; parse multiple rules from a stream, possibly a file - although the real -;; objective is to parse rules out of a block of text from a textarea - -(ns mw-parser.bulk +(ns ^{:doc "parse multiple rules from a stream, possibly a file." + :author "Simon Brooke"} + mw-parser.bulk (:use mw-parser.declarative mw-engine.utils clojure.java.io [clojure.string :only [split trim]]) (:import (java.io BufferedReader StringReader))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 2 +;; of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;; USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (defn comment? "Is this `line` a comment?" [line] diff --git a/src/mw_parser/core.clj b/src/mw_parser/core.clj index aafd595..f130f81 100644 --- a/src/mw_parser/core.clj +++ b/src/mw_parser/core.clj @@ -1,3 +1,30 @@ +(ns ^{:doc "A very simple parser which parses production rules." + :author "Simon Brooke"} + mw-parser.core + (:use mw-engine.utils + [clojure.string :only [split trim triml]]) + (:gen-class) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 2 +;; of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;; USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; A very simple parser which parses production rules of the following forms: ;; ;; * "if altitude is less than 100 and state is forest then state should be climax and deer should be 3" @@ -11,35 +38,31 @@ ;; * "if state is in grassland or pasture or heath and 4 neighbours are water then state should be village" ;; * "if state is forest or state is climax and some neighbours have state equal to fire then 3 in 5 chance that state should be fire" ;; * "if state is pasture and more than 3 neighbours have state equal to scrub then state should be scrub" -;; * +;; * ;; ;; it generates rules in the form expected by `mw-engine.core`, q.v. ;; -;; It is, as I say, very simple; it generates a complete rule, or it fails completely, returning nil. +;; It is, as I say, very simple; it generates a complete rule, or it fails completely, returning nil. ;; Very occasionally it generates a wrong rule - one which is not a correct translation of the rule ;; 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 the parser that is actually used currently; but see also insta.clj, +;; 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 - [clojure.string :only [split trim triml]]) - (:gen-class) -) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declare parse-conditions) (declare parse-not-condition) (declare parse-simple-condition) -;; a regular expression which matches string representation of numbers +;; a regular expression which matches string representation of positive numbers (def re-number #"^[0-9.]*$") ;; error thrown when an attempt is made to set a reserved property -(def reserved-properties-error +(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 (def bad-parse-error "I did not understand '%s'") @@ -48,12 +71,12 @@ "If this token appears to represent an explicit number, return that number; otherwise, make a keyword of it and return that." [token] - (cond + (cond (re-matches re-number token) (read-string token) (keyword? token) token true (keyword token))) -;; Generally all functions in this file with names beginning 'parse-' take a +;; Generally all functions in this file with names beginning 'parse-' take a ;; sequence of tokens (and in some cases other optional arguments) and return a ;; vector comprising ;; @@ -70,7 +93,7 @@ (if (and value (re-matches re-number value)) [(read-string value) remainder])) (defn parse-property-int - "Parse a token assumed to be the name of a property of the current cell, + "Parse a token assumed to be the name of a property of the current cell, whose value is assumed to be an integer." [[value & remainder]] (if value [(list 'get-int 'cell (keyword value)) remainder])) @@ -115,12 +138,12 @@ [(cons value others) remainder]) true [(list value) tokens])))) - -(defn parse-value + +(defn parse-value "Parse a value from among these `tokens`. If `expect-int` is true, return an integer or something which will evaluate to an integer." ([tokens expect-int] - (or + (or (parse-disjunct-value tokens expect-int) (parse-simple-value tokens expect-int))) ([tokens] @@ -158,18 +181,18 @@ (list '> value1 property value2)) rest]))) (defn- parse-is-condition - "Parse clauses of the form 'x is y', 'x is in y or z...', + "Parse clauses of the form 'x is y', 'x is in y or z...', 'x is between y and z', 'x is more than y' or 'x is less than y'. It is necessary to disambiguate whether value is a numeric or keyword." [[property IS value & rest]] - (cond + (cond (member? IS '("is" "are")) (let [tokens (cons property (cons value rest))] - (cond + (cond (re-matches re-number value) [(list '= (list 'get-int 'cell (keyword property)) (read-string value)) rest] value [(list '= (list (keyword property) 'cell) (keyword value)) rest])))) -(defn- parse-not-condition +(defn- parse-not-condition "Parse the negation of a simple condition." [[property IS NOT & rest]] (cond (and (member? IS '("is" "are")) (= NOT "not")) @@ -179,11 +202,11 @@ [(list 'not condition) remainder]))))) (defn- gen-neighbours-condition - ([comp1 quantity property value remainder comp2 distance] - [(list comp1 + ([comp1 quantity property value remainder comp2 distance] + [(list comp1 (list 'count - (list 'get-neighbours-with-property-value 'world - '(cell :x) '(cell :y) distance + (list 'get-neighbours-with-property-value 'world + '(cell :x) '(cell :y) distance (keyword property) (keyword-or-numeric value) comp2)) quantity) remainder]) @@ -195,21 +218,21 @@ [[MORE THAN n NEIGHBOURS WITHIN distance have-or-are & rest]] (let [quantity (first (parse-numeric-value (list n))) comparator (cond (= MORE "more") '> - (member? MORE '("fewer" "less")) '<)] + (member? MORE '("fewer" "less")) '<)] (cond (not= WITHIN "within") - (parse-comparator-neighbours-condition - (flatten + (parse-comparator-neighbours-condition + (flatten ;; two tokens were mis-parsed as 'within distance' that weren't ;; actually 'within' and a distance. Splice in 'within 1' and try ;; again. (list MORE THAN n NEIGHBOURS "within" "1" WITHIN distance have-or-are rest))) - (and quantity + (and quantity comparator (= THAN "than") (= NEIGHBOURS "neighbours")) (cond - (= have-or-are "are") + (= have-or-are "are") (let [[value & remainder] rest dist (gen-token-value distance true)] (gen-neighbours-condition comparator quantity :state value remainder = dist)) @@ -217,16 +240,16 @@ (let [[property comp1 comp2 value & remainder] rest dist (gen-token-value distance true)] (cond (and (= comp1 "equal") (= comp2 "to")) - (gen-neighbours-condition comparator quantity property + (gen-neighbours-condition comparator quantity property value remainder = dist) (and (= comp1 "more") (= comp2 "than")) - (gen-neighbours-condition comparator quantity property + (gen-neighbours-condition comparator quantity property value remainder > dist) (and (= comp1 "less") (= comp2 "than")) - (gen-neighbours-condition comparator quantity property + (gen-neighbours-condition comparator quantity property value remainder < dist) )))))) - + (defn parse-some-neighbours-condition [[SOME NEIGHBOURS & rest]] (cond @@ -236,18 +259,18 @@ (defn parse-simple-neighbours-condition "Parse conditions of the form '...6 neighbours are [condition]'" [[n NEIGHBOURS WITHIN distance have-or-are & rest]] - (let [quantity (first (parse-numeric-value (list n)))] + (let [quantity (first (parse-numeric-value (list n)))] (cond (and quantity (= NEIGHBOURS "neighbours")) (cond (not= WITHIN "within") (parse-simple-neighbours-condition - (flatten + (flatten ;; two tokens were mis-parsed as 'within distance' that weren't ;; actually 'within' and a distance. Splice in 'within 1' and try ;; again. (list n NEIGHBOURS "within" "1" WITHIN distance have-or-are rest))) - (= have-or-are "are") + (= have-or-are "are") (let [[value & remainder] rest dist (gen-token-value distance true)] (gen-neighbours-condition '= quantity :state value remainder = dist)) @@ -255,16 +278,16 @@ (let [[property comp1 comp2 value & remainder] rest dist (gen-token-value distance true)] (cond (and (= comp1 "equal") (= comp2 "to")) - (gen-neighbours-condition '= quantity property value remainder = + (gen-neighbours-condition '= quantity property value remainder = dist) (and (= comp1 "more") (= comp2 "than")) - (gen-neighbours-condition '= quantity property value remainder > + (gen-neighbours-condition '= quantity property value remainder > dist) (and (= comp1 "less") (= comp2 "than")) - (gen-neighbours-condition '= quantity property value remainder < + (gen-neighbours-condition '= quantity property value remainder < dist) )))))) - + (defn parse-neighbours-condition "Parse conditions referring to neighbours" [tokens] @@ -320,30 +343,30 @@ (= IF "if") (parse-conditions tokens))) -(defn- parse-arithmetic-action +(defn- parse-arithmetic-action "Parse actions of the form '[property] should be [property] [arithmetic-operator] [value]', e.g. 'fertility should be fertility + 1', or 'deer should be deer - wolves'." [previous [prop1 SHOULD BE prop2 operator value & rest]] (cond (member? prop1 '("x" "y")) - (throw + (throw (Exception. reserved-properties-error)) (and (= SHOULD "should") (= BE "be") (member? operator '("+" "-" "*" "/"))) [(list 'merge (or previous 'cell) - {(keyword prop1) (list 'int + {(keyword prop1) (list 'int (list (symbol operator) (list 'get-int 'cell (keyword prop2)) (cond (re-matches re-number value) (read-string value) true (list 'get-int 'cell (keyword value)))))}) rest])) -(defn- parse-set-action +(defn- parse-set-action "Parse actions of the form '[property] should be [value].'" [previous [property SHOULD BE value & rest]] - (cond + (cond (member? property '("x" "y")) - (throw + (throw (Exception. reserved-properties-error)) (and (= SHOULD "should") (= BE "be")) [(list 'merge (or previous 'cell) @@ -362,19 +385,19 @@ (parse-actions left (rest remainder)) true (list left))))) -(defn- parse-probability +(defn- parse-probability "Parse a probability of an action from this collection of tokens" [previous [n CHANCE IN m & tokens]] - (cond + (cond (and (= CHANCE "chance")(= IN "in")) (let [[action remainder] (parse-actions previous tokens)] (cond action - [(list 'cond - (list '< - (list 'rand + [(list 'cond + (list '< + (list 'rand (first (parse-simple-value (list m) true))) - (first (parse-simple-value (list n) true))) - action) remainder])))) + (first (parse-simple-value (list n) true))) + action) remainder])))) (defn- parse-right-hand-side "Parse the right hand side ('then...') of a production rule." @@ -384,27 +407,27 @@ (parse-probability nil tokens) (parse-actions nil tokens)))) -(defn parse-rule - "Parse a complete rule from this `line`, expected to be either a string or a +(defn parse-rule + "Parse a complete rule from this `line`, expected to be either a string or a sequence of string tokens. Return the rule in the form of an S-expression. Throws an exception if parsing fails." [line] (cond - (string? line) + (string? line) (let [rule (parse-rule (split (triml line) #"\s+"))] (cond rule rule true (throw (Exception. (format bad-parse-error line))))) - true + true (let [[left remainder] (parse-left-hand-side line) [right junk] (parse-right-hand-side remainder)] - (cond + (cond ;; there should be a valide left hand side and a valid right hand side ;; there shouldn't be anything left over (junk should be empty) (and left right (empty? junk)) (list 'fn ['cell 'world] (list 'if left right)))))) -(defn compile-rule +(defn compile-rule "Parse this `rule-text`, a string conforming to the grammar of MicroWorld rules, into Clojure source, and then compile it into an anonymous function object, getting round the problem of binding mw-engine.utils in @@ -417,7 +440,7 @@ (do (use 'mw-engine.utils) (let [afn (eval (parse-rule rule-text))] - (cond + (cond (and afn return-tuple?)(list afn (trim rule-text)) true afn)))) ([rule-text] diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index 69792a4..410b247 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -1,11 +1,31 @@ -(ns mw-parser.declarative - (:use mw-engine.utils - mw-parser.utils - [mw-parser.errors :as pe] - [mw-parser.generate :as pg] - [mw-parser.simplify :as ps] - [clojure.string :only [split trim triml]]) - (:require [instaparse.core :as insta])) +(ns ^{:doc "A very simple parser which parses production rules." + :author "Simon Brooke"} + mw-parser.declarative + (:require [instaparse.core :as insta] + [clojure.string :refer [split trim triml]] + [mw-parser.errors :as pe] + [mw-parser.generate :as pg] + [mw-parser.simplify :as ps] + [mw-parser.utils :refer [rule?]])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 2 +;; of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;; USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (def grammar @@ -93,3 +113,12 @@ (compile-rule rule-text false))) +(ps/simplify + (parse-rule + "if more than 2 neighbours have altitude equal to 11 then state should be beach")) + +(pg/generate + (ps/simplify + (parse-rule + "if more than 2 neighbours have altitude equal to 11 then state should be beach"))) + diff --git a/src/mw_parser/errors.clj b/src/mw_parser/errors.clj index 8db5f6c..6e5efbe 100644 --- a/src/mw_parser/errors.clj +++ b/src/mw_parser/errors.clj @@ -1,4 +1,27 @@ -(ns mw-parser.errors) +(ns ^{:doc "Display parse errors in a format which makes it easy for the user + to see where the error occurred." + :author "Simon Brooke"} + mw-parser.errors) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 2 +;; of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;; USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; error thrown when an attempt is made to set a reserved property (def reserved-properties-error diff --git a/src/mw_parser/generate.clj b/src/mw_parser/generate.clj index d27647d..3c86b02 100644 --- a/src/mw_parser/generate.clj +++ b/src/mw_parser/generate.clj @@ -1,8 +1,29 @@ -(ns mw-parser.generate - (:use mw-engine.utils - mw-parser.utils +(ns ^{:doc "Generate Clojure source from simplified parse trees." + :author "Simon Brooke"} + mw-parser.generate + (:require [mw-engine.utils :refer []] + [mw-parser.utils :refer [assert-type TODO]] [mw-parser.errors :as pe])) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 2 +;; of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;; USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (declare generate generate-action) @@ -24,6 +45,8 @@ (defn generate-condition + "From this `tree`, assumed to be a syntactically correct condition clause, + generate and return the appropriate clojure fragment." [tree] (assert-type tree :CONDITION) (generate (second tree))) @@ -31,18 +54,24 @@ (defn generate-conjunct-condition [tree] + "From this `tree`, assumed to be a syntactically conjunct correct condition clause, + generate and return the appropriate clojure fragment." (assert-type tree :CONJUNCT-CONDITION) (cons 'and (map generate (rest tree)))) (defn generate-disjunct-condition + "From this `tree`, assumed to be a syntactically correct disjunct condition clause, + generate and return the appropriate clojure fragment." [tree] (assert-type tree :DISJUNCT-CONDITION) (cons 'or (map generate (rest tree)))) (defn generate-ranged-property-condition - "Generate a property condition where the expression is a numeric range" + "From this `tree`, assumed to be a syntactically property condition clause for + this `property` where the `expression` is a numeric range, generate and return + the appropriate clojure fragment." [tree property expression] (assert-type tree :PROPERTY-CONDITION) (assert-type (nth tree 3) :RANGE-EXPRESSION) @@ -55,7 +84,9 @@ (defn generate-disjunct-property-condition - "Generate a property condition where the expression is a disjunct expression. + "From this `tree`, assumed to be a syntactically property condition clause + where the expression is a a disjunction, generate and return + the appropriate clojure fragment. TODO: this is definitely still wrong!" ([tree] (let [property (generate (second tree)) @@ -70,6 +101,8 @@ (defn generate-property-condition + "From this `tree`, assumed to be a syntactically property condition clause, + generate and return the appropriate clojure fragment." ([tree] (assert-type tree :PROPERTY-CONDITION) (if @@ -100,6 +133,8 @@ (defn generate-qualifier + "From this `tree`, assumed to be a syntactically correct qualifier, + generate and return the appropriate clojure fragment." [tree] (if (= (count tree) 2) @@ -109,6 +144,8 @@ (defn generate-simple-action + "From this `tree`, assumed to be a syntactically correct simple action, + generate and return the appropriate clojure fragment." ([tree] (assert-type tree :SIMPLE-ACTION) (generate-simple-action tree [])) @@ -126,6 +163,8 @@ (defn generate-probable-action + "From this `tree`, assumed to be a syntactically correct probable action, + generate and return the appropriate clojure fragment." ([tree] (assert-type tree :PROBABLE-ACTION) (generate-probable-action tree [])) @@ -142,6 +181,8 @@ (defn generate-action + "From this `tree`, assumed to be a syntactically correct action, + generate and return the appropriate clojure fragment." [tree others] (case (first tree) :ACTIONS (generate-action (first tree) others) @@ -151,6 +192,8 @@ (defn generate-multiple-actions + "From this `tree`, assumed to be one or more syntactically correct actions, + generate and return the appropriate clojure fragment." [tree] (assert-type tree :ACTIONS) (generate-action (first (rest tree)) (second (rest tree)))) @@ -166,6 +209,8 @@ (defn generate-numeric-expression + "From this `tree`, assumed to be a syntactically correct numeric expression, + generate and return the appropriate clojure fragment." [tree] (assert-type tree :NUMERIC-EXPRESSION) (case (count tree) @@ -182,6 +227,7 @@ ([tree] (assert-type tree :NEIGHBOURS-CONDITION) (case (first (second tree)) + :NUMBER (read-string (second (second tree))) :QUANTIFIER (generate-neighbours-condition tree (first (second (second tree)))) :QUALIFIER (cons (generate (second tree)) (rest (generate (nth tree 2)))))) ([tree quantifier-type] diff --git a/src/mw_parser/simplifier.clj b/src/mw_parser/simplifier.clj deleted file mode 100644 index 9943256..0000000 --- a/src/mw_parser/simplifier.clj +++ /dev/null @@ -1,92 +0,0 @@ -(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")) diff --git a/src/mw_parser/simplify.clj b/src/mw_parser/simplify.clj index 3ac2c3c..1a5e8c6 100644 --- a/src/mw_parser/simplify.clj +++ b/src/mw_parser/simplify.clj @@ -1,12 +1,33 @@ -(ns mw-parser.simplify - (:use mw-engine.utils - mw-parser.utils)) +(ns ^{:doc "Simplify a parse tree." + :author "Simon Brooke"} + mw-parser.simplify + (:require [mw-engine.utils :refer [member?]])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 2 +;; of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;; USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (declare simplify) (defn simplify-qualifier "Given that this `tree` fragment represents a qualifier, what - qualifier is that?" + qualifier is that?" [tree] (cond (empty? tree) nil @@ -19,9 +40,16 @@ (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." + only two elements, the second is semantically sufficient." [tree] - (if (= (count tree) 2) (simplify (second tree)) tree)) + (if (= (count tree) 2) (simplify (nth tree 1)) tree)) + + +(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 @@ -31,18 +59,24 @@ (if (coll? tree) (case (first tree) + ;; '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." + ;; TODO: fix this so it actually works. + :ALL [:COMPARATIVE '= 8] :ACTION (simplify-second-of-two tree) - :ACTIONS (cons (first tree) (simplify (rest tree))) - :CHANCE-IN nil + :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) + :NONE [:COMPARATIVE '= 0] + :NUMBER tree :PROPERTY (simplify-second-of-two tree) - :PROPERTY-CONDITION-OR-EXPRESSION (simplify-second-of-two tree) + :QUALIFIER (simplify-qualifier tree) + :QUANTIFIER (simplify-quantifier tree) + :SOME [:COMPARATIVE '> 0] :SPACE nil - :THEN nil - :AND nil :VALUE (simplify-second-of-two tree) (remove nil? (map simplify tree))) tree)) + diff --git a/src/mw_parser/utils.clj b/src/mw_parser/utils.clj index 14e91c5..42f8995 100644 --- a/src/mw_parser/utils.clj +++ b/src/mw_parser/utils.clj @@ -1,4 +1,25 @@ -(ns mw-parser.utils) +(ns ^{:doc "Utilities used in more than one namespace within the parser." + :author "Simon Brooke"} + mw-parser.utils) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 2 +;; of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;; USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defn rule? diff --git a/test/mw_parser/declarative_test.clj b/test/mw_parser/declarative_test.clj index 93ffdbb..d5c6fd3 100644 --- a/test/mw_parser/declarative_test.clj +++ b/test/mw_parser/declarative_test.clj @@ -472,3 +472,15 @@ (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.")) )) + +(deftest regression-tests + (testing "Rule in default set which failed on switchover to declarative rules" + (let [afn (compile-rule "if state is scrub then 1 chance in 5 state should be forest") + 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 state should be scrub")))] + (is (= (:state (apply afn (list {:x 1 :y 1} world))) :forest) + "Centre cell is scrub, so rule should fire") + (is (= (:state (apply afn (list {:x 2 :y 1} world))) :beach) + "Middle cell of the strip is not scrub, so rule should not fire.")))) From ca9553fe83396638a66927ae6944f2d0be6cee60 Mon Sep 17 00:00:00 2001 From: simon Date: Sat, 13 Aug 2016 23:20:34 +0100 Subject: [PATCH 5/9] Back to no exceptions in test, still two test failures which need to be investigated. --- src/mw_parser/declarative.clj | 10 ---------- src/mw_parser/simplify.clj | 15 +++++---------- 2 files changed, 5 insertions(+), 20 deletions(-) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index 410b247..81325fd 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -112,13 +112,3 @@ ([rule-text] (compile-rule rule-text false))) - -(ps/simplify - (parse-rule - "if more than 2 neighbours have altitude equal to 11 then state should be beach")) - -(pg/generate - (ps/simplify - (parse-rule - "if more than 2 neighbours have altitude equal to 11 then state should be beach"))) - diff --git a/src/mw_parser/simplify.clj b/src/mw_parser/simplify.clj index 1a5e8c6..843ed80 100644 --- a/src/mw_parser/simplify.clj +++ b/src/mw_parser/simplify.clj @@ -59,23 +59,18 @@ (if (coll? tree) (case (first tree) - ;; '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." - ;; TODO: fix this so it actually works. - :ALL [:COMPARATIVE '= 8] :ACTION (simplify-second-of-two tree) - :ACTIONS (simplify-second-of-two tree) + :ACTIONS (cons (first tree) (simplify (rest tree))) + :CHANCE-IN nil :COMPARATIVE (simplify-second-of-two tree) :CONDITION (simplify-second-of-two tree) :CONDITIONS (simplify-second-of-two tree) :EXPRESSION (simplify-second-of-two tree) - :NONE [:COMPARATIVE '= 0] - :NUMBER tree :PROPERTY (simplify-second-of-two tree) - :QUALIFIER (simplify-qualifier tree) - :QUANTIFIER (simplify-quantifier tree) - :SOME [:COMPARATIVE '> 0] + :PROPERTY-CONDITION-OR-EXPRESSION (simplify-second-of-two tree) :SPACE nil + :THEN nil + :AND nil :VALUE (simplify-second-of-two tree) (remove nil? (map simplify tree))) tree)) From 948bd7e5f2dfa21e33e5bb8902e248623eaecf5b Mon Sep 17 00:00:00 2001 From: simon Date: Sun, 21 Aug 2016 13:50:54 +0100 Subject: [PATCH 6/9] Standardised header comments in line with current best practice. --- src/mw_parser/bulk.clj | 36 ++++++++------- src/mw_parser/core.clj | 92 ++++++++++++++++++++------------------ src/mw_parser/simplify.clj | 36 ++++++++------- src/mw_parser/utils.clj | 36 ++++++++------- 4 files changed, 108 insertions(+), 92 deletions(-) diff --git a/src/mw_parser/bulk.clj b/src/mw_parser/bulk.clj index 2aba74c..cff7b49 100644 --- a/src/mw_parser/bulk.clj +++ b/src/mw_parser/bulk.clj @@ -8,22 +8,26 @@ (:import (java.io BufferedReader StringReader))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, -;; USA. -;; +;;;; +;;;; mw-parser: a rule parser for MicroWorld. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License +;;;; as published by the Free Software Foundation; either version 2 +;;;; of the License, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Copyright (C) 2014 Simon Brooke +;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/mw_parser/core.clj b/src/mw_parser/core.clj index f130f81..820f353 100644 --- a/src/mw_parser/core.clj +++ b/src/mw_parser/core.clj @@ -7,51 +7,55 @@ ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, -;; USA. -;; +;;;; +;;;; mw-parser: a rule parser for MicroWorld. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License +;;;; as published by the Free Software Foundation; either version 2 +;;;; of the License, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Copyright (C) 2014 Simon Brooke +;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; A very simple parser which parses production rules of the following forms: -;; -;; * "if altitude is less than 100 and state is forest then state should be climax and deer should be 3" -;; * "if altitude is 100 or fertility is 25 then state should be heath and fertility should be 24.3" -;; * "if altitude is 100 or fertility is 25 then state should be heath" -;; * "if deer is more than 2 and wolves is 0 and fertility is more than 20 then deer should be deer + 2" -;; * "if deer is more than 1 and wolves is more than 1 then deer should be deer - wolves" -;; * "if state is grassland and 4 neighbours have state equal to water then state should be village" -;; * "if state is forest and fertility is between 55 and 75 then state should be climax" -;; * "if 6 neighbours have state equal to water then state should be village" -;; * "if state is in grassland or pasture or heath and 4 neighbours are water then state should be village" -;; * "if state is forest or state is climax and some neighbours have state equal to fire then 3 in 5 chance that state should be fire" -;; * "if state is pasture and more than 3 neighbours have state equal to scrub then state should be scrub" -;; * -;; -;; it generates rules in the form expected by `mw-engine.core`, q.v. -;; -;; It is, as I say, very simple; it generates a complete rule, or it fails completely, returning nil. -;; Very occasionally it generates a wrong rule - one which is not a correct translation of the rule -;; 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 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. -;; +;;;; +;;;; A very simple parser which parses production rules of the following forms: +;;;; +;;;; * "if altitude is less than 100 and state is forest then state should be climax and deer should be 3" +;;;; * "if altitude is 100 or fertility is 25 then state should be heath and fertility should be 24.3" +;;;; * "if altitude is 100 or fertility is 25 then state should be heath" +;;;; * "if deer is more than 2 and wolves is 0 and fertility is more than 20 then deer should be deer + 2" +;;;; * "if deer is more than 1 and wolves is more than 1 then deer should be deer - wolves" +;;;; * "if state is grassland and 4 neighbours have state equal to water then state should be village" +;;;; * "if state is forest and fertility is between 55 and 75 then state should be climax" +;;;; * "if 6 neighbours have state equal to water then state should be village" +;;;; * "if state is in grassland or pasture or heath and 4 neighbours are water then state should be village" +;;;; * "if state is forest or state is climax and some neighbours have state equal to fire then 3 in 5 chance that state should be fire" +;;;; * "if state is pasture and more than 3 neighbours have state equal to scrub then state should be scrub" +;;;; * +;;;; +;;;; it generates rules in the form expected by `mw-engine.core`, q.v. +;;;; +;;;; It is, as I say, very simple; it generates a complete rule, or it fails completely, returning nil. +;;;; Very occasionally it generates a wrong rule - one which is not a correct translation of the rule +;;;; 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 parser is now obsolete, but is retained in the codebase for now in +;;;; case it is of use to anyone. Prefer the declarative.clj parser. +;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declare parse-conditions) diff --git a/src/mw_parser/simplify.clj b/src/mw_parser/simplify.clj index 843ed80..00529a8 100644 --- a/src/mw_parser/simplify.clj +++ b/src/mw_parser/simplify.clj @@ -4,22 +4,26 @@ (:require [mw-engine.utils :refer [member?]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, -;; USA. -;; +;;;; +;;;; mw-parser: a rule parser for MicroWorld. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License +;;;; as published by the Free Software Foundation; either version 2 +;;;; of the License, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Copyright (C) 2014 Simon Brooke +;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/mw_parser/utils.clj b/src/mw_parser/utils.clj index 42f8995..e8bdca8 100644 --- a/src/mw_parser/utils.clj +++ b/src/mw_parser/utils.clj @@ -3,22 +3,26 @@ mw-parser.utils) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, -;; USA. -;; +;;;; +;;;; mw-parser: a rule parser for MicroWorld. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License +;;;; as published by the Free Software Foundation; either version 2 +;;;; of the License, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Copyright (C) 2014 Simon Brooke +;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From ddf967088ebbe399a60c2b669263bd2f5cf5138a Mon Sep 17 00:00:00 2001 From: simon Date: Sun, 21 Aug 2016 13:51:56 +0100 Subject: [PATCH 7/9] Standarised header comments --- src/mw_parser/declarative.clj | 36 +++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/src/mw_parser/declarative.clj b/src/mw_parser/declarative.clj index 81325fd..62e1b03 100644 --- a/src/mw_parser/declarative.clj +++ b/src/mw_parser/declarative.clj @@ -9,22 +9,26 @@ [mw-parser.utils :refer [rule?]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License -;; as published by the Free Software Foundation; either version 2 -;; of the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, -;; USA. -;; +;;;; +;;;; mw-parser: a rule parser for MicroWorld. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU General Public License +;;;; as published by the Free Software Foundation; either version 2 +;;;; of the License, or (at your option) any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this program; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;;; USA. +;;;; +;;;; Copyright (C) 2014 Simon Brooke +;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 88d707a32eb9fc899688cf5ce29217d8147e5dc3 Mon Sep 17 00:00:00 2001 From: simon Date: Fri, 23 Sep 2016 12:53:00 +0100 Subject: [PATCH 8/9] Fixed all failing tests. Two issues: 1. The regression test failures were both errors in the tests rather than in the code under test; 2. The failure in the 'bulk' test relates to the fact that the new declarative parser cannot cope with trailing whitespace. --- resources/rules.txt | 10 +++++----- src/mw_parser/bulk.clj | 2 +- test/mw_parser/bulk_test.clj | 15 ++++++++------- test/mw_parser/declarative_test.clj | 7 ++++--- 4 files changed, 18 insertions(+), 16 deletions(-) diff --git a/resources/rules.txt b/resources/rules.txt index 0356227..d7f2d5f 100644 --- a/resources/rules.txt +++ b/resources/rules.txt @@ -6,19 +6,19 @@ ## Vegetation rules ;; rules which populate the world with plants -;; Occasionally, passing birds plant tree seeds into grassland +;; Occasionally, passing birds plant tree seeds into grassland if state is grassland then 1 chance in 10 state should be heath ;; heath below the treeline grows gradually into forest -if state is heath and altitude is less than 120 then state should be scrub +if state is heath and altitude is less than 120 then state should be scrub if state is scrub then 1 chance in 5 state should be forest ;; Forest on fertile land grows to climax -if state is forest and fertility is more than 5 and altitude is less than 70 then state should be climax - +if state is forest and fertility is more than 5 and altitude is less than 70 then state should be climax + ;; Climax forest occasionally catches fire (e.g. lightning strikes) if state is climax then 1 chance in 500 state should be fire @@ -40,7 +40,7 @@ if state is waste then state should be grassland ## Potential blockers -;; Forest increases soil fertility. +;; Forest increases soil fertility. if state is in forest or climax then fertility should be fertility + 1 diff --git a/src/mw_parser/bulk.clj b/src/mw_parser/bulk.clj index cff7b49..45540e8 100644 --- a/src/mw_parser/bulk.clj +++ b/src/mw_parser/bulk.clj @@ -41,7 +41,7 @@ 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")))) + (map #(parse-rule (trim %)) (remove comment? (split string #"\n")))) (defn parse-file "Parse rules from successive lines in the file loaded from this `filename`. diff --git a/test/mw_parser/bulk_test.clj b/test/mw_parser/bulk_test.clj index e80acc7..1155361 100644 --- a/test/mw_parser/bulk_test.clj +++ b/test/mw_parser/bulk_test.clj @@ -7,18 +7,19 @@ (testing "Bulk (file) parsing and compilation" (is (= (count (parse-file (as-file "resources/rules.txt"))) 15) "Should parse all rules and throw no exceptions") - (is (empty? - (remove #(= % 'fn) - (map first - (parse-file + (is (empty? + (remove #(= % ':RULE) + (map first + (parse-file (as-file "resources/rules.txt"))))) "all parsed rules should be lambda sexprs") (is (= (count (compile-file (as-file "resources/rules.txt"))) 15) "Should compile all rules and throw no exceptions") (is (empty? - (remove ifn? - (map first - (compile-file + (remove ifn? + (map first + (compile-file (as-file "resources/rules.txt"))))) "all compiled rules should be ifns") )) + diff --git a/test/mw_parser/declarative_test.clj b/test/mw_parser/declarative_test.clj index d5c6fd3..bc7485f 100644 --- a/test/mw_parser/declarative_test.clj +++ b/test/mw_parser/declarative_test.clj @@ -475,12 +475,13 @@ (deftest regression-tests (testing "Rule in default set which failed on switchover to declarative rules" - (let [afn (compile-rule "if state is scrub then 1 chance in 5 state should be forest") + (let [afn (compile-rule "if state is scrub then 1 chance in 1 state should be forest") 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 state should be scrub")))] - (is (= (:state (apply afn (list {:x 1 :y 1} world))) :forest) + (is (= (:state (apply afn (list (get-cell world 1 1) world))) :forest) "Centre cell is scrub, so rule should fire") - (is (= (:state (apply afn (list {:x 2 :y 1} world))) :beach) + (is (= (apply afn (list (get-cell world 2 1) world)) nil) "Middle cell of the strip is not scrub, so rule should not fire.")))) + From 2788cac40f41eeb6439fde56fcbdcfd5e0ed9b6e Mon Sep 17 00:00:00 2001 From: simon Date: Sat, 24 Sep 2016 14:20:43 +0100 Subject: [PATCH 9/9] 1: Great renaming in pursuit of a CLJC-viable parser. There is still a bug here, or between here and microworld.engine, because compiled rules which pass all the unit tests nevertheless fail in integration testing. --- project.clj | 9 ++++---- .../microworld/parser/bulk.cljc} | 8 +++---- .../microworld/parser/core.cljc} | 12 +++++----- .../microworld/parser/declarative.cljc} | 19 ++++++++-------- .../microworld/parser/errors.cljc} | 2 +- .../microworld/parser/generate.cljc} | 10 ++++----- .../microworld/parser/simplify.cljc} | 6 ++--- .../microworld/parser/utils.cljc} | 4 ++-- .../parser}/bulk_test.clj | 4 ++-- .../parser}/core_test.clj | 8 +++---- .../parser}/declarative_test.clj | 22 ++++++++++++++----- .../parser}/generate_test.clj | 12 +++++----- 12 files changed, 64 insertions(+), 52 deletions(-) rename src/{mw_parser/bulk.clj => cljc/microworld/parser/bulk.cljc} (93%) rename src/{mw_parser/core.clj => cljc/microworld/parser/core.cljc} (98%) rename src/{mw_parser/declarative.clj => cljc/microworld/parser/declarative.cljc} (90%) rename src/{mw_parser/errors.clj => cljc/microworld/parser/errors.cljc} (99%) rename src/{mw_parser/generate.clj => cljc/microworld/parser/generate.cljc} (97%) rename src/{mw_parser/simplify.clj => cljc/microworld/parser/simplify.cljc} (95%) rename src/{mw_parser/utils.clj => cljc/microworld/parser/utils.cljc} (96%) rename test/{mw_parser => microworld/parser}/bulk_test.clj (92%) rename test/{mw_parser => microworld/parser}/core_test.clj (99%) rename test/{mw_parser => microworld/parser}/declarative_test.clj (98%) rename test/{mw_parser => microworld/parser}/generate_test.clj (93%) diff --git a/project.clj b/project.clj index d48db45..9463073 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject mw-parser "0.1.5-SNAPSHOT" +(defproject mw-parser "3.0.0-SNAPSHOT" :description "Parser for production rules for MicroWorld engine" :url "http://www.journeyman.cc/microworld" :manifest { @@ -8,11 +8,12 @@ "build-signature-timestamp" "unset" "Implementation-Version" "unset" } + :source-paths ["src/clj" "src/cljc"] :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.6.0"] + :dependencies [[org.clojure/clojure "1.8.0"] [org.clojure/tools.trace "0.7.9"] - [instaparse "1.4.1"] - [mw-engine "0.1.5-SNAPSHOT"] + [com.lucasbradstreet/instaparse-cljs "1.4.1.2"] + [mw-engine "3.0.0-SNAPSHOT"] ]) diff --git a/src/mw_parser/bulk.clj b/src/cljc/microworld/parser/bulk.cljc similarity index 93% rename from src/mw_parser/bulk.clj rename to src/cljc/microworld/parser/bulk.cljc index 45540e8..e9efd2e 100644 --- a/src/mw_parser/bulk.clj +++ b/src/cljc/microworld/parser/bulk.cljc @@ -1,15 +1,15 @@ (ns ^{:doc "parse multiple rules from a stream, possibly a file." :author "Simon Brooke"} - mw-parser.bulk - (:use mw-parser.declarative - mw-engine.utils + microworld.parser.bulk + (:use microworld.parser.declarative + microworld.engine.utils clojure.java.io [clojure.string :only [split trim]]) (:import (java.io BufferedReader StringReader))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; -;;;; mw-parser: a rule parser for MicroWorld. +;;;; microworld.parser: a rule parser for MicroWorld. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License diff --git a/src/mw_parser/core.clj b/src/cljc/microworld/parser/core.cljc similarity index 98% rename from src/mw_parser/core.clj rename to src/cljc/microworld/parser/core.cljc index 820f353..746a4f1 100644 --- a/src/mw_parser/core.clj +++ b/src/cljc/microworld/parser/core.cljc @@ -1,14 +1,14 @@ (ns ^{:doc "A very simple parser which parses production rules." :author "Simon Brooke"} - mw-parser.core - (:use mw-engine.utils + microworld.parser.core + (:use microworld.engine.utils [clojure.string :only [split trim triml]]) (:gen-class) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; -;;;; mw-parser: a rule parser for MicroWorld. +;;;; microworld.parser: a rule parser for MicroWorld. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License @@ -44,7 +44,7 @@ ;;;; * "if state is pasture and more than 3 neighbours have state equal to scrub then state should be scrub" ;;;; * ;;;; -;;;; it generates rules in the form expected by `mw-engine.core`, q.v. +;;;; it generates rules in the form expected by `microworld.engine.core`, q.v. ;;;; ;;;; It is, as I say, very simple; it generates a complete rule, or it fails completely, returning nil. ;;;; Very occasionally it generates a wrong rule - one which is not a correct translation of the rule @@ -434,7 +434,7 @@ (defn compile-rule "Parse this `rule-text`, a string conforming to the grammar of MicroWorld rules, into Clojure source, and then compile it into an anonymous - function object, getting round the problem of binding mw-engine.utils in + function object, getting round the problem of binding microworld.engine.utils in the compiling environment. If `return-tuple?` is present and true, return a list comprising the anonymous function compiled, and the function from which it was compiled. @@ -442,7 +442,7 @@ Throws an exception if parsing fails." ([rule-text return-tuple?] (do - (use 'mw-engine.utils) + (use 'microworld.engine.utils) (let [afn (eval (parse-rule rule-text))] (cond (and afn return-tuple?)(list afn (trim rule-text)) diff --git a/src/mw_parser/declarative.clj b/src/cljc/microworld/parser/declarative.cljc similarity index 90% rename from src/mw_parser/declarative.clj rename to src/cljc/microworld/parser/declarative.cljc index 62e1b03..f084716 100644 --- a/src/mw_parser/declarative.clj +++ b/src/cljc/microworld/parser/declarative.cljc @@ -1,16 +1,16 @@ (ns ^{:doc "A very simple parser which parses production rules." :author "Simon Brooke"} - mw-parser.declarative + microworld.parser.declarative (:require [instaparse.core :as insta] [clojure.string :refer [split trim triml]] - [mw-parser.errors :as pe] - [mw-parser.generate :as pg] - [mw-parser.simplify :as ps] - [mw-parser.utils :refer [rule?]])) + [microworld.parser.errors :as pe] + [microworld.parser.generate :as pg] + [microworld.parser.simplify :as ps] + [microworld.parser.utils :refer [rule?]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; -;;;; mw-parser: a rule parser for MicroWorld. +;;;; microworld.parser: a rule parser for MicroWorld. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License @@ -96,7 +96,7 @@ (defn compile-rule "Parse this `rule-text`, a string conforming to the grammar of MicroWorld rules, into Clojure source, and then compile it into an anonymous - function object, getting round the problem of binding mw-engine.utils in + function object, getting round the problem of binding microworld.engine.utils in the compiling environment. If `return-tuple?` is present and true, return a list comprising the anonymous function compiled, and the function from which it was compiled. @@ -106,11 +106,12 @@ (assert (string? rule-text)) (let [rule (trim rule-text) tree (ps/simplify (parse-rule rule)) - afn (if (rule? tree) (eval (pg/generate tree)) + clj (pg/generate tree) + afn (if (rule? tree) (eval clj) ;; else (pe/throw-parse-exception tree))] (if return-tuple? - (list afn rule) + (list afn {:rule rule :clojure (print-str clj)}) ;; else afn))) ([rule-text] diff --git a/src/mw_parser/errors.clj b/src/cljc/microworld/parser/errors.cljc similarity index 99% rename from src/mw_parser/errors.clj rename to src/cljc/microworld/parser/errors.cljc index 6e5efbe..55bc354 100644 --- a/src/mw_parser/errors.clj +++ b/src/cljc/microworld/parser/errors.cljc @@ -1,7 +1,7 @@ (ns ^{:doc "Display parse errors in a format which makes it easy for the user to see where the error occurred." :author "Simon Brooke"} - mw-parser.errors) + microworld.parser.errors) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; diff --git a/src/mw_parser/generate.clj b/src/cljc/microworld/parser/generate.cljc similarity index 97% rename from src/mw_parser/generate.clj rename to src/cljc/microworld/parser/generate.cljc index 3c86b02..e7a9e5f 100644 --- a/src/mw_parser/generate.clj +++ b/src/cljc/microworld/parser/generate.cljc @@ -1,9 +1,9 @@ (ns ^{:doc "Generate Clojure source from simplified parse trees." :author "Simon Brooke"} - mw-parser.generate - (:require [mw-engine.utils :refer []] - [mw-parser.utils :refer [assert-type TODO]] - [mw-parser.errors :as pe])) + microworld.parser.generate + (:require [microworld.engine.utils :refer []] + [microworld.parser.utils :refer [assert-type TODO]] + [microworld.parser.errors :as pe])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -246,7 +246,7 @@ (list 'count (list 'remove 'false? (list 'map (list 'fn ['cell] property-condition) - (list 'mw-engine.utils/get-neighbours 'world 'cell distance)))) quantity)) + (list 'microworld.engine.utils/get-neighbours 'world 'cell distance)))) quantity)) ([comp1 quantity property-condition] (generate-neighbours-condition comp1 quantity property-condition 1))) diff --git a/src/mw_parser/simplify.clj b/src/cljc/microworld/parser/simplify.cljc similarity index 95% rename from src/mw_parser/simplify.clj rename to src/cljc/microworld/parser/simplify.cljc index 00529a8..1e32c61 100644 --- a/src/mw_parser/simplify.clj +++ b/src/cljc/microworld/parser/simplify.cljc @@ -1,11 +1,11 @@ (ns ^{:doc "Simplify a parse tree." :author "Simon Brooke"} - mw-parser.simplify - (:require [mw-engine.utils :refer [member?]])) + microworld.parser.simplify + (:require [microworld.engine.utils :refer [member?]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; -;;;; mw-parser: a rule parser for MicroWorld. +;;;; microworld.parser: a rule parser for MicroWorld. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License diff --git a/src/mw_parser/utils.clj b/src/cljc/microworld/parser/utils.cljc similarity index 96% rename from src/mw_parser/utils.clj rename to src/cljc/microworld/parser/utils.cljc index e8bdca8..9390b18 100644 --- a/src/mw_parser/utils.clj +++ b/src/cljc/microworld/parser/utils.cljc @@ -1,10 +1,10 @@ (ns ^{:doc "Utilities used in more than one namespace within the parser." :author "Simon Brooke"} - mw-parser.utils) + microworld.parser.utils) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; -;;;; mw-parser: a rule parser for MicroWorld. +;;;; microworld.parser: a rule parser for MicroWorld. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License diff --git a/test/mw_parser/bulk_test.clj b/test/microworld/parser/bulk_test.clj similarity index 92% rename from test/mw_parser/bulk_test.clj rename to test/microworld/parser/bulk_test.clj index 1155361..6b74a61 100644 --- a/test/mw_parser/bulk_test.clj +++ b/test/microworld/parser/bulk_test.clj @@ -1,7 +1,7 @@ -(ns mw-parser.bulk-test +(ns microworld.parser.bulk-test (:use clojure.java.io) (:require [clojure.test :refer :all] - [mw-parser.bulk :refer :all])) + [microworld.parser.bulk :refer :all])) (deftest bulk-parsing-test (testing "Bulk (file) parsing and compilation" diff --git a/test/mw_parser/core_test.clj b/test/microworld/parser/core_test.clj similarity index 99% rename from test/mw_parser/core_test.clj rename to test/microworld/parser/core_test.clj index f0e152e..bd55717 100644 --- a/test/mw_parser/core_test.clj +++ b/test/microworld/parser/core_test.clj @@ -1,9 +1,9 @@ -(ns mw-parser.core-test +(ns microworld.parser.core-test (:use clojure.pprint - mw-engine.core - mw-engine.world) + microworld.engine.core + microworld.engine.world) (:require [clojure.test :refer :all] - [mw-parser.core :refer :all])) + [microworld.parser.core :refer :all])) (deftest primitives-tests (testing "Simple functions supporting the parser" diff --git a/test/mw_parser/declarative_test.clj b/test/microworld/parser/declarative_test.clj similarity index 98% rename from test/mw_parser/declarative_test.clj rename to test/microworld/parser/declarative_test.clj index bc7485f..953582d 100644 --- a/test/mw_parser/declarative_test.clj +++ b/test/microworld/parser/declarative_test.clj @@ -1,11 +1,11 @@ -(ns mw-parser.declarative-test +(ns microworld.parser.declarative-test (:use clojure.pprint - mw-engine.core - mw-engine.world - mw-engine.utils - mw-parser.utils) + microworld.engine.core + microworld.engine.world + microworld.engine.utils + microworld.parser.utils) (:require [clojure.test :refer :all] - [mw-parser.declarative :refer :all])) + [microworld.parser.declarative :refer :all])) (deftest rules-tests (testing "Rule parser - does not test whether generated functions actually work, just that something is generated!" @@ -485,3 +485,13 @@ (is (= (apply afn (list (get-cell world 2 1) world)) nil) "Middle cell of the strip is not scrub, so rule should not fire.")))) +(deftest regression-2-tests + (testing "Still getting fails althought tests for these fails fail." + (is + (= + (:state + (apply + (compile-rule "if state is scrub then 1 chance in 1 state should be forest") + (list {:state :scrub} {}))) + :forest)))) + diff --git a/test/mw_parser/generate_test.clj b/test/microworld/parser/generate_test.clj similarity index 93% rename from test/mw_parser/generate_test.clj rename to test/microworld/parser/generate_test.clj index eacd48c..a860424 100644 --- a/test/mw_parser/generate_test.clj +++ b/test/microworld/parser/generate_test.clj @@ -1,11 +1,11 @@ -(ns mw-parser.generate-test +(ns microworld.parser.generate-test (:use clojure.pprint - mw-engine.core - mw-engine.world - mw-engine.utils - mw-parser.utils) + microworld.engine.core + microworld.engine.world + microworld.engine.utils + microworld.parser.utils) (:require [clojure.test :refer :all] - [mw-parser.generate :refer :all])) + [microworld.parser.generate :refer :all])) (deftest expressions-tests