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

Major restructuring, switched over to use the new declarative parser.

Browse source 
Some rules in the bulk test file no longer parse, but all rules in the
demonstration rule-sets do.
This commit is contained in:
simon 2016-08-10 20:11:17 +01:00
parent 9836cbff50
commit d2a73ba408
8 changed files with 488 additions and 444 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/mw_parser/bulk.clj
View file

@ -2,7 +2,7 @@
;; objective is to parse rules out of a block of text from a textarea ;; objective is to parse rules out of a block of text from a textarea
(ns mw-parser.bulk (ns mw-parser.bulk
(:use mw-parser.core (:use mw-parser.declarative
mw-engine.utils mw-engine.utils
clojure.java.io clojure.java.io
[clojure.string :only [split trim]]) [clojure.string :only [split trim]])

418
src/mw_parser/declarative.clj
View file

@ -1,19 +1,13 @@
(ns mw-parser.declarative (ns mw-parser.declarative
(:use mw-engine.utils (: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]]) [clojure.string :only [split trim triml]])
(:require [instaparse.core :as insta])) (: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 (def grammar
;; in order to simplify translation into other natural languages, all ;; in order to simplify translation into other natural languages, all
;; TOKENS within the parser should be unambiguous ;; TOKENS within the parser should be unambiguous
@ -69,395 +63,33 @@
SPACE := #' *'"; 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 (def parse-rule
"Parse the argument, assumed to be a string in the correct syntax, and return a parse tree." "Parse the argument, assumed to be a string in the correct syntax, and return a parse tree."
(insta/parser grammar)) (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 (defn compile-rule
"Compile this `rule`, assumed to be a string with appropriate syntax, into a function of two arguments, "Parse this `rule-text`, a string conforming to the grammar of MicroWorld rules,
a `cell` and a `world`, having the same semantics." into Clojure source, and then compile it into an anonymous
[rule] function object, getting round the problem of binding mw-engine.utils in
(assert (string? rule)) the compiling environment. If `return-tuple?` is present and true, return
(let [tree (simplify (parse-rule rule))] a list comprising the anonymous function compiled, and the function from
(if (rule? tree) (eval (generate tree)) which it was compiled.
(throw-parse-exception tree))))
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)))

45
src/mw_parser/errors.clj Normal file
View file

@ -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))))

270
src/mw_parser/generate.clj Normal file
View file

@ -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))

48
src/mw_parser/simplify.clj Normal file
View file

@ -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))

39
src/mw_parser/utils.clj Normal file
View file

@ -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))))))

53
test/mw_parser/declarative_test.clj
View file

@ -2,7 +2,8 @@
(:use clojure.pprint (:use clojure.pprint
mw-engine.core mw-engine.core
mw-engine.world mw-engine.world
mw-engine.utils) mw-engine.utils
mw-parser.utils)
(:require [clojure.test :refer :all] (:require [clojure.test :refer :all]
[mw-parser.declarative :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"))) (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 (deftest exception-tests
(testing "Constructions which should cause exceptions to be thrown" (testing "Constructions which should cause exceptions to be thrown"
@ -100,6 +52,7 @@
"Exception thrown on attempt to set 'y'") "Exception thrown on attempt to set 'y'")
)) ))
(deftest correctness-tests (deftest correctness-tests
;; these are, in so far as possible, the same as the correctness-tests in core-tests - i.e., the two compilers ;; 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. ;; compile the same language.

57
test/mw_parser/generate_test.clj Normal file
View file

@ -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}))))
))