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

Compare commits

merge into: simon:master
Branches Tags
simon:master
simon:develop
simon:0.1.6_MAINTENANCE
simon:0.1.5_MAINTENANCE
simon:feature/1
simon:0.1.3_MAINTENANCE
...
pull from: simon:0.1.5_MAINTENANCE
Branches Tags
simon:develop
simon:0.1.6_MAINTENANCE
simon:0.1.5_MAINTENANCE
simon:feature/1
simon:master
simon:0.1.3_MAINTENANCE

10 commits
master ... 0.1.5_MAIN

Author SHA1 Message Date
simon 5089615401 Upversioned from 0.1.5-SNAPSHOT to 0.1.5 for release 2016-12-27 16:19:01 +00:00
simon a68a3c9135 Revert to using 'core' parser rather than new declarative parser, which still 
has bugs.
 2016-12-27 15:53:29 +00:00
simon 88d707a32e 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.
 2016-09-23 12:53:00 +01:00
simon ddf967088e Standarised header comments 2016-08-21 13:51:56 +01:00
simon 948bd7e5f2 Standardised header comments in line with current best practice. 2016-08-21 13:50:54 +01:00
simon ca9553fe83 Back to no exceptions in test, still two test failures which need to be investigated. 2016-08-13 23:20:34 +01:00
simon 3168c1b2fb Trying to get code quality up, but in the process I've broken something - 
I think, the simplifier.
 2016-08-13 19:45:43 +01:00
simon d2a73ba408 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.
 2016-08-10 20:11:17 +01:00
simon 9836cbff50 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.
 2016-08-10 19:23:16 +01:00
simon 1c6ceb899c Substantially closer to the declarative parser fully working, but not 
yet perfect.
 2016-08-10 13:30:15 +01:00
13 changed files with 1150 additions and 885 deletions
Show stats Expand all files Collapse all files

4
project.clj
View file

@ -1,4 +1,4 @@
(defproject mw-parser "0.1.5-SNAPSHOT"
(defproject mw-parser "0.1.5"
:description "Parser for production rules for MicroWorld engine"
:url "http://www.journeyman.cc/microworld"
:manifest {
@ -14,5 +14,5 @@
:dependencies [[org.clojure/clojure "1.6.0"]
[org.clojure/tools.trace "0.7.9"]
[instaparse "1.4.1"]
[mw-engine "0.1.5-SNAPSHOT"]
[mw-engine "0.1.5"]
])

33
src/mw_parser/bulk.clj
View file

@ -1,13 +1,36 @@
;; 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.core
mw-engine.utils
clojure.java.io
[clojure.string :only [split trim]])
(:import (java.io BufferedReader StringReader)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 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
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn comment?
"Is this `line` a comment?"
[line]
@ -18,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`.

85
src/mw_parser/core.clj
View file

@ -1,41 +1,68 @@
;; 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.
(ns mw-parser.core
(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)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 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 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)
(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

376
src/mw_parser/declarative.clj
View file

@ -1,29 +1,48 @@
(ns mw-parser.declarative
(:use mw-engine.utils
[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?]]))
;; 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")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 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
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def grammar
;; 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 +50,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,310 +78,41 @@
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
"Marker to indicate I'm not yet finished!"
[message]
message)
(declare generate simplify)
(defn suitable-fragment?
"Return `true` if `tree-fragment` appears to be a tree fragment of the expected `type`."
[tree-fragment type]
(and (coll? tree-fragment)
(= (first tree-fragment) type)))
(defn assert-type
"If `tree-fragment` is not a tree fragment of the expected `type`, throw an exception."
[tree-fragment type]
(assert (suitable-fragment? tree-fragment type)
(throw (Exception. (format "Expected a %s fragment" type)))))
(defn generate-rule
"From this `tree`, assumed to be a syntactically correct rule specification,
generate and return the appropriate rule as a function of two arguments."
[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 (nth tree 1)))
(defn generate-condition
[tree]
(assert-type tree :CONDITION)
(generate (nth tree 1)))
(defn generate-conjunct-condition
[tree]
(assert-type tree :CONJUNCT-CONDITION)
(list 'and (generate (nth tree 1))(generate (nth tree 3))))
(defn generate-disjunct-condition
[tree]
(assert-type tree :DISJUNCT-CONDITION)
(list 'or (generate (nth tree 1))(generate (nth tree 3))))
(defn generate-ranged-property-condition
"Generate a property condition where the expression is a numeric range"
[tree property expression]
(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 (nth tree 1))
qualifier (generate (nth tree 2))
expression (generate (nth tree 3))]
(generate-disjunct-property-condition tree property qualifier expression)))
([tree property qualifier expression]
(let [e (list 'some (list 'fn ['i] '(= i value)) (list 'quote expression))]
(list 'let ['value (list property 'cell)]
(if (= qualifier '=) e
(list 'not e))))))
(defn generate-property-condition
([tree]
(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 (nth tree 1))
qualifier (generate (nth tree 2))
expression (generate (nth tree 3))]
(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-simple-action
[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}))))
(defn generate-multiple-actions
[tree]
(assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment")
(conj 'do (map generate-simple-action (rest tree))))
(defn generate-disjunct-value
"Generate a disjunct value. Essentially what we need here is to generate a
flat list of values, since the `member` has already been taken care of."
[tree]
(assert-type tree :DISJUNCT-VALUE)
(if (= (count tree) 4)
(cons (generate (second tree)) (generate (nth tree 3)))
(list (generate (second tree)))))
(defn generate-numeric-expression
[tree]
(assert-type tree :NUMERIC-EXPRESSION)
(case (first (second tree))
:SYMBOL (list (keyword (second (second tree))) 'cell)
(generate (second tree))))
(defn generate-neighbours-condition
"Generate code for a condition which refers to neighbours."
([tree]
(assert-type tree :NEIGHBOURS-CONDITION)
(generate-neighbours-condition tree (first (second (second tree)))))
([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
"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 (nth tree 2))
: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))
:PROPERTY (list (generate (second tree)) 'cell) ;; dubious - may not be right
:PROPERTY-CONDITION (generate-property-condition tree)
:QUALIFIER (generate (second tree))
:RULE (generate-rule tree)
:SIMPLE-ACTION (generate-simple-action tree)
:SYMBOL (keyword (second tree))
:VALUE (generate (second 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 (nth tree 1)) tree))
(defn rule?
"Return true if the argument appears to be a parsed rule tree, else false."
[maybe-rule]
(and (coll? maybe-rule) (= (first maybe-rule) :RULE)))
(defn simplify
"Simplify/canonicalise this `tree`. Opportunistically replace complex fragments with
semantically identical simpler fragments"
[tree]
(if
(coll? tree)
(case (first tree)
:ACTION (simplify-second-of-two tree)
:ACTIONS (simplify-second-of-two tree)
:COMPARATIVE (simplify-second-of-two tree)
:CONDITION (simplify-second-of-two tree)
:CONDITIONS (simplify-second-of-two tree)
:EXPRESSION (simplify-second-of-two tree)
:NOT nil ;; TODO is this right?!? It looks wrong
:PROPERTY (simplify-second-of-two tree)
:SPACE nil
:THEN 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)))

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

@ -0,0 +1,68 @@
(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
"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))))

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

@ -0,0 +1,316 @@
(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)
(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
"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)))
(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
"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)
(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
"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))
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
"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
(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
"From this `tree`, assumed to be a syntactically correct qualifier,
generate and return the appropriate clojure fragment."
[tree]
(if
(= (count tree) 2)
(generate (second tree))
;; else
(generate (nth tree 2))))
(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 []))
([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
"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 []))
([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
"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)
: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
"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))))
(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
"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)
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))
: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]
(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))

92
src/mw_parser/simplifier.clj
View file

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

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

@ -0,0 +1,81 @@
(ns ^{:doc "Simplify a parse tree."
:author "Simon Brooke"}
mw-parser.simplify
(:require [mw-engine.utils :refer [member?]]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 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
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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-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)
: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))

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

@ -0,0 +1,64 @@
(ns ^{:doc "Utilities used in more than one namespace within the parser."
:author "Simon Brooke"}
mw-parser.utils)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 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
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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))))))

1
test/mw_parser/bulk_test.clj
View file

@ -22,3 +22,4 @@
(as-file "resources/rules.txt")))))
"all compiled rules should be ifns")
))

732
test/mw_parser/declarative_test.clj
View file

@ -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,51 +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 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"
@ -96,422 +52,436 @@
"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.
(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 + leaffall")]
(is (= (:fertility
(apply afn
(list {:state :climax
:fertility 0
:leaffall 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."))
))
(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 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 (get-cell world 1 1) world))) :forest)
"Centre cell is scrub, so rule should fire")
(is (= (apply afn (list (get-cell world 2 1) world)) nil)
"Middle cell of the strip is not scrub, so rule should not fire."))))

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