simon/mw-parser
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Very considerable progress on the new parser. The deer/wolves rules still fail,

Browse source 
as does one complicated form of neighbours rule; but I'm almost there.
This commit is contained in:
simon 2016-08-03 17:41:48 +01:00
parent d44ba60802
commit e40d89fdef
2 changed files with 76 additions and 64 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

109
src/mw_parser/declarative.clj
View file

@ -24,7 +24,7 @@
CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION;
WITHIN-CONDITION := NEIGHBOURS-CONDITION SPACE WITHIN SPACE NUMERIC-EXPRESSION; 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; NEIGHBOURS-CONDITION := WITHIN-CONDITION | QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION;
PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION; PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION | VALUE;
EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE;
SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE;
DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE; DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE;
@ -49,7 +49,7 @@
BETWEEN := 'between'; BETWEEN := 'between';
WITHIN := 'within'; WITHIN := 'within';
IN := 'in'; IN := 'in';
MORE := 'more'; MORE := 'more' | 'greater';
LESS := 'less' | 'fewer'; LESS := 'less' | 'fewer';
OPERATOR := '+' | '-' | '*' | '/'; OPERATOR := '+' | '-' | '*' | '/';
NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors'; NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors';
@ -75,10 +75,13 @@
(declare generate simplify) (declare generate simplify)
(defn suitable-fragment? (defn suitable-fragment?
"Return `true` if `tree-fragment` appears to be a tree fragment of the expected `type`." "Return `true` if `tree-fragment` appears to be a tree fragment of the expected `type`."
[tree-fragment type] [tree-fragment type]
(and (coll? tree-fragment)(= (first tree-fragment) type))) (and (coll? tree-fragment)
(= (first tree-fragment) type)))
(defn assert-type (defn assert-type
"If `tree-fragment` is not a tree fragment of the expected `type`, throw an exception." "If `tree-fragment` is not a tree fragment of the expected `type`, throw an exception."
@ -86,6 +89,7 @@
(assert (suitable-fragment? tree-fragment type) (assert (suitable-fragment? tree-fragment type)
(throw (Exception. (format "Expected a %s fragment" type))))) (throw (Exception. (format "Expected a %s fragment" type)))))
(defn generate-rule (defn generate-rule
"From this `tree`, assumed to be a syntactically correct rule specification, "From this `tree`, assumed to be a syntactically correct rule specification,
generate and return the appropriate rule as a function of two arguments." generate and return the appropriate rule as a function of two arguments."
@ -93,6 +97,7 @@
(assert-type tree :RULE) (assert-type tree :RULE)
(list 'fn ['cell 'world] (list 'if (generate (nth tree 2)) (generate (nth tree 3))))) (list 'fn ['cell 'world] (list 'if (generate (nth tree 2)) (generate (nth tree 3)))))
(defn generate-conditions (defn generate-conditions
"From this `tree`, assumed to be a syntactically correct conditions clause, "From this `tree`, assumed to be a syntactically correct conditions clause,
generate and return the appropriate clojure fragment." generate and return the appropriate clojure fragment."
@ -100,21 +105,25 @@
(assert-type tree :CONDITIONS) (assert-type tree :CONDITIONS)
(generate (nth tree 1))) (generate (nth tree 1)))
(defn generate-condition (defn generate-condition
[tree] [tree]
(assert-type tree :CONDITION) (assert-type tree :CONDITION)
(generate (nth tree 1))) (generate (nth tree 1)))
(defn generate-conjunct-condition (defn generate-conjunct-condition
[tree] [tree]
(assert-type tree :CONJUNCT-CONDITION) (assert-type tree :CONJUNCT-CONDITION)
(list 'and (generate (nth tree 1))(generate (nth tree 3)))) (list 'and (generate (nth tree 1))(generate (nth tree 3))))
(defn generate-disjunct-condition (defn generate-disjunct-condition
[tree] [tree]
(assert-type tree :DISJUNCT-CONDITION) (assert-type tree :DISJUNCT-CONDITION)
(list 'or (generate (nth tree 1))(generate (nth tree 3)))) (list 'or (generate (nth tree 1))(generate (nth tree 3))))
(defn generate-ranged-property-condition (defn generate-ranged-property-condition
"Generate a property condition where the expression is a numeric range" "Generate a property condition where the expression is a numeric range"
[tree property expression] [tree property expression]
@ -127,6 +136,7 @@
'upper (list 'max l1 l2)] 'upper (list 'max l1 l2)]
(list 'and (list '>= pv 'lower)(list '<= pv 'upper))))) (list 'and (list '>= pv 'lower)(list '<= pv 'upper)))))
(defn generate-disjunct-property-condition (defn generate-disjunct-property-condition
"Generate a property condition where the expression is a disjunct expression. "Generate a property condition where the expression is a disjunct expression.
TODO: this is definitely still wrong!" TODO: this is definitely still wrong!"
@ -141,10 +151,22 @@
(if (= qualifier '=) e (if (= qualifier '=) e
(list 'not e)))))) (list 'not e))))))
(defn generate-property-condition (defn generate-property-condition
([tree] ([tree]
(assert-type tree :PROPERTY-CONDITION) (assert-type tree :PROPERTY-CONDITION)
(generate-property-condition tree (first (nth tree 3)))) (if
(and (= (count tree) 2) (= (first (second tree)) :SYMBOL))
;; it's a shorthand for 'state equal to symbol'. This should probably have
;; been handled in simplify...
(generate-property-condition
(list
:PROPERTY-CONDITION
'(:SYMBOL "state")
'(:QUALIFIER (:EQUIVALENCE (:EQUAL "equal to")))
(second tree)))
;; otherwise...
(generate-property-condition tree (first (nth tree 3)))))
([tree expression-type] ([tree expression-type]
(assert-type tree :PROPERTY-CONDITION) (assert-type tree :PROPERTY-CONDITION)
(let [property (generate (nth tree 1)) (let [property (generate (nth tree 1))
@ -155,6 +177,7 @@
:RANGE-EXPRESSION (generate-ranged-property-condition tree property expression) :RANGE-EXPRESSION (generate-ranged-property-condition tree property expression)
(list qualifier (list property 'cell) expression))))) (list qualifier (list property 'cell) expression)))))
(defn generate-simple-action (defn generate-simple-action
[tree] [tree]
(assert-type tree :SIMPLE-ACTION) (assert-type tree :SIMPLE-ACTION)
@ -164,11 +187,13 @@
(throw (Exception. reserved-properties-error)) (throw (Exception. reserved-properties-error))
(list 'merge 'cell {property expression})))) (list 'merge 'cell {property expression}))))
(defn generate-multiple-actions (defn generate-multiple-actions
[tree] [tree]
(assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment")
(conj 'do (map generate-simple-action (rest tree)))) (conj 'do (map generate-simple-action (rest tree))))
(defn generate-disjunct-value (defn generate-disjunct-value
"Generate a disjunct value. Essentially what we need here is to generate a "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." flat list of values, since the `member` has already been taken care of."
@ -178,6 +203,7 @@
(cons (generate (second tree)) (generate (nth tree 3))) (cons (generate (second tree)) (generate (nth tree 3)))
(list (generate (second tree))))) (list (generate (second tree)))))
(defn generate-numeric-expression (defn generate-numeric-expression
[tree] [tree]
(assert-type tree :NUMERIC-EXPRESSION) (assert-type tree :NUMERIC-EXPRESSION)
@ -185,58 +211,31 @@
:SYMBOL (list (keyword (second (second tree))) 'cell) :SYMBOL (list (keyword (second (second tree))) 'cell)
(generate (second tree)))) (generate (second tree))))
(defn generate-neighbours-condition (defn generate-neighbours-condition
"Generate code for a condition which refers to neighbours." "Generate code for a condition which refers to neighbours."
([tree] ([tree]
(generate-neighbours-condition tree (first (second tree)))) (assert-type tree :NEIGHBOURS-CONDITION)
(generate-neighbours-condition tree (first (second (second tree)))))
([tree quantifier-type] ([tree quantifier-type]
(let [quantifier (second (second tree)) (let [quantifier (second tree)
pc (generate (nth tree 4))] pc (generate (nth tree 4))]
(case quantifier-type (case quantifier-type
:NUMBER (generate-neighbours-condition '= (read-string quantifier) pc 1) :NUMBER (generate-neighbours-condition '= (read-string (second (second quantifier))) pc 1)
:SOME (generate-neighbours-condition '> 0 pc 1) :SOME (generate-neighbours-condition '> 0 pc 1)
:QUANTIFIER :MORE (let [value (generate (nth quantifier 3))]
(let [comparative (generate (simplify (second quantifier))) (generate-neighbours-condition '> value pc 1))
value (simplify (nth quantifier 5))] :LESS (let [value (generate (nth quantifier 3))]
(generate-neighbours-condition comparative value pc 1))))) (generate-neighbours-condition '< value pc 1)))))
([comp1 quantity property-condition distance] ([comp1 quantity property-condition distance]
(list comp1 (list comp1
(list 'count (list 'remove false (list 'map (list 'fn ['cell] property-condition) '(get-neighbours cell world distance)))) quantity)) (list 'count
(list 'remove 'false?
(list 'map (list 'fn ['cell] property-condition)
(list 'mw-engine.utils/get-neighbours 'world 'cell distance)))) quantity))
([comp1 quantity property-condition] ([comp1 quantity property-condition]
(generate-neighbours-condition comp1 quantity property-condition 1))) (generate-neighbours-condition comp1 quantity property-condition 1)))
;; (def s1 "if 3 neighbours have state equal to forest then state should be forest")
;; (def s2 "if some neighbours have state equal to forest then state should be forest")
;; (def s3 "if more than 3 neighbours have state equal to forest then state should be forest")
;; (def s4 "if fewer than 3 neighbours have state equal to forest then state should be forest")
;; (def s5 "if all neighbours have state equal to forest then state should be forest")
;; (def s6 "if more than 3 neighbours within 2 have state equal to forest then state should be forest")
;; (nth (simplify (parse-rule s1)) 2)
;; (second (nth (simplify (parse-rule s1)) 2))
;; (nth (simplify (parse-rule s2)) 2)
;; (map simplify (nth (simplify (parse-rule s2)) 2))
;; ;; (second (nth (simplify (parse-rule s2)) 2))
;; ;; (nth (simplify (parse-rule s3)) 2)
;; (second (nth (simplify (parse-rule s3)) 2))
;; (map simplify (second (nth (simplify (parse-rule s3)) 2)))
;; ;; (nth (simplify (parse-rule s4)) 2)
;; ;; (second (nth (simplify (parse-rule s4)) 2))
;; ;; (nth (simplify (parse-rule s5)) 2)
;; ;; (second (nth (simplify (parse-rule s5)) 2))
;; ;; (nth (simplify (parse-rule s6)) 2)
;; ;; (second (nth (simplify (parse-rule s6)) 2))
;; ;; (generate (nth (nth (simplify (parse-rule s5)) 2) 4))
;; ;; (generate (nth (simplify (parse-rule s2)) 2))
;; ;; (generate (nth (simplify (parse-rule s1)) 2))
;; (generate-neighbours-condition '= 3 '(= (:state cell) :forest) 1)
;; (generate-neighbours-condition (nth (simplify (parse-rule s3)) 2))
;; (generate-neighbours-condition (nth (simplify (parse-rule s2)) 2))
;; (generate-neighbours-condition (nth (simplify (parse-rule s1)) 2))
(defn generate (defn generate
"Generate code for this (fragment of a) parse tree" "Generate code for this (fragment of a) parse tree"
@ -274,8 +273,6 @@
(map generate tree)) (map generate tree))
tree)) tree))
(generate '(:PROPERTY-CONDITION (:SYMBOL "wolves") (:QUALIFIER (:COMPARATIVE-QUALIFIER (:IS "are") (:MORE "more") (:THAN "than"))) (:SYMBOL "deer")))
(defn simplify-qualifier (defn simplify-qualifier
"Given that this `tree` fragment represents a qualifier, what "Given that this `tree` fragment represents a qualifier, what
@ -315,12 +312,10 @@
:CONDITION (simplify-second-of-two tree) :CONDITION (simplify-second-of-two tree)
:CONDITIONS (simplify-second-of-two tree) :CONDITIONS (simplify-second-of-two tree)
:EXPRESSION (simplify-second-of-two tree) :EXPRESSION (simplify-second-of-two tree)
;; :QUANTIFIER (simplify-second-of-two tree) :NOT nil ;; TODO is this right?!? It looks wrong
:NOT nil
:PROPERTY (simplify-second-of-two tree) :PROPERTY (simplify-second-of-two tree)
:SPACE nil :SPACE nil
:THEN nil :THEN nil
;; :QUALIFIER (simplify-qualifier tree)
:VALUE (simplify-second-of-two tree) :VALUE (simplify-second-of-two tree)
(remove nil? (map simplify tree))) (remove nil? (map simplify tree)))
tree)) tree))
@ -332,7 +327,15 @@
(defn explain-parse-error-reason (defn explain-parse-error-reason
"Attempt to explain the reason for the parse error." "Attempt to explain the reason for the parse error."
[reason] [reason]
(str "Expecting one of (" (apply str (map #(str (:expecting %) " ") (first reason))) ")")) (str "Expecting one of (" (apply str (map #(str (:expecting %) " ") reason)) ")"))
(defn parser-error-to-map
[parser-error]
(let [m (reduce (fn [map item](merge map {(first item)(second item)})) {} parser-error)
reason (map
#(reduce (fn [map item] (merge {(first item) (second item)} map)) {} %)
(:reason m))]
(merge m {:reason reason})))
(defn throw-parse-exception (defn throw-parse-exception
"Construct a helpful error message from this `parser-error`, and throw an exception with that message." "Construct a helpful error message from this `parser-error`, and throw an exception with that message."
@ -342,11 +345,11 @@
[ [
;; the error structure is a list, such that each element is a list of two items, and ;; the 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 ;; the first element in each sublist is a keyword. Easier to work with it as a map
error-map (reduce (fn [map item](merge map {(first item)(rest item)})) {} parser-error) error-map (parser-error-to-map parser-error)
text (first (:text error-map)) text (:text error-map)
reason (explain-parse-error-reason (:reason error-map)) reason (explain-parse-error-reason (:reason error-map))
;; rules have only one line, by definition; we're interested in the column ;; rules have only one line, by definition; we're interested in the column
column (if (:column error-map)(first (:column error-map)) 0) column (if (:column error-map)(:column error-map) 0)
;; create a cursor to point to that column ;; create a cursor to point to that column
cursor (apply str (reverse (conj (repeat column " ") "^"))) cursor (apply str (reverse (conj (repeat column " ") "^")))
message (format bad-parse-error text cursor reason) message (format bad-parse-error text cursor reason)

31
test/mw_parser/declarative_test.clj
View file

@ -1,7 +1,8 @@
(ns mw-parser.declarative-test (ns mw-parser.declarative-test
(:use clojure.pprint (:use clojure.pprint
mw-engine.core mw-engine.core
mw-engine.world) mw-engine.world
mw-engine.utils)
(:require [clojure.test :refer :all] (:require [clojure.test :refer :all]
[mw-parser.declarative :refer :all])) [mw-parser.declarative :refer :all]))
@ -103,8 +104,8 @@
(is (= (apply afn (list {:state :new} nil)) (is (= (apply afn (list {:state :new} nil))
{:state :grassland}) {:state :grassland})
"Rule fires when condition is met") "Rule fires when condition is met")
(is (nil? (apply afn (list {:state :forest} nil)))) (is (nil? (apply afn (list {:state :forest} nil)))
"Rule doesn't fire when condition isn't met")) "Rule doesn't fire when condition isn't met")))
(testing "Condition conjunction rule" (testing "Condition conjunction rule"
(let [afn (compile-rule "if state is new and altitude is 0 then state should be water")] (let [afn (compile-rule "if state is new and altitude is 0 then state should be water")]
@ -196,13 +197,13 @@
(is (nil? (apply afn (list {:altitude 10} nil))) (is (nil? (apply afn (list {:altitude 10} nil)))
"Rule does not fire when condition is not met"))) "Rule does not fire when condition is not met")))
;; (testing "Property is less than property" (testing "Property is less than property"
;; (let [afn (compile-rule "if wolves are less than deer then deer should be deer - wolves")] (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)) (is (= (apply afn (list {:deer 3 :wolves 2} nil))
;; {:deer 1 :wolves 2}) {:deer 1 :wolves 2})
;; "Rule fires when condition is met") "Rule fires when condition is met")
;; (is (nil? (apply afn (list {:deer 2 :wolves 3} nil))) (is (nil? (apply afn (list {:deer 2 :wolves 3} nil)))
;; "Rule does not fire when condition is not met"))) "Rule does not fire when condition is not met")))
(testing "Number neighbours have property equal to value" (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") (let [afn (compile-rule "if 3 neighbours have state equal to new then state should be water")
@ -214,7 +215,15 @@
"Middle cell has eight neighbours, so rule does not fire.")) "Middle cell has eight neighbours, so rule does not fire."))
(let [afn (compile-rule "if 3 neighbours are new then state should be water") (let [afn (compile-rule "if 3 neighbours are new then state should be water")
world (make-world 3 3)] world (make-world 3 3)]
;; 'are new' should be the same as 'have state equal to new' ;; 'are new' and 'is new' should be the same as 'have state equal to new'
(is (= (apply afn (list {:x 0 :y 0} world))
{:state :water :x 0 :y 0})
"Rule fires when condition is met (in a new world all cells are new, corner cell has three neighbours)")
(is (nil? (apply afn (list {:x 1 :y 1} world)))
"Middle cell has eight neighbours, so rule does not fire."))
(let [afn (compile-rule "if 3 neighbours is new then state should be water")
world (make-world 3 3)]
;; 'are new' and 'is new' should be the same as 'have state equal to new'
(is (= (apply afn (list {:x 0 :y 0} world)) (is (= (apply afn (list {:x 0 :y 0} world))
{:state :water :x 0 :y 0}) {: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)") "Rule fires when condition is met (in a new world all cells are new, corner cell has three neighbours)")