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

Compare commits

base: 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
..
compare: 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" :description "Parser for production rules for MicroWorld engine"
:url "http://www.journeyman.cc/microworld" :url "http://www.journeyman.cc/microworld"
:manifest { :manifest {
@ -14,5 +14,5 @@
:dependencies [[org.clojure/clojure "1.6.0"] :dependencies [[org.clojure/clojure "1.6.0"]
[org.clojure/tools.trace "0.7.9"] [org.clojure/tools.trace "0.7.9"]
[instaparse "1.4.1"] [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 (ns ^{:doc "parse multiple rules from a stream, possibly a file."
;; objective is to parse rules out of a block of text from a textarea :author "Simon Brooke"}
mw-parser.bulk
(ns mw-parser.bulk
(:use mw-parser.core (:use mw-parser.core
mw-engine.utils mw-engine.utils
clojure.java.io clojure.java.io
[clojure.string :only [split trim]]) [clojure.string :only [split trim]])
(:import (java.io BufferedReader StringReader))) (: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? (defn comment?
"Is this `line` a comment?" "Is this `line` a comment?"
[line] [line]
@ -18,7 +41,7 @@
lines delimited by the new-line character. Return a list of S-expressions." lines delimited by the new-line character. Return a list of S-expressions."
[string] [string]
;; TODO: tried to do this using with-open, but couldn't make it work. ;; 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 (defn parse-file
"Parse rules from successive lines in the file loaded from this `filename`. "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: (ns ^{:doc "A very simple parser which parses production rules."
;; :author "Simon Brooke"}
;; * "if altitude is less than 100 and state is forest then state should be climax and deer should be 3" mw-parser.core
;; * "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
(:use mw-engine.utils (:use mw-engine.utils
[clojure.string :only [split trim triml]]) [clojure.string :only [split trim triml]])
(:gen-class) (: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-conditions)
(declare parse-not-condition) (declare parse-not-condition)
(declare parse-simple-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.]*$") (def re-number #"^[0-9.]*$")
;; error thrown when an attempt is made to set a reserved property ;; 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 (ns ^{:doc "A very simple parser which parses production rules."
(:use mw-engine.utils :author "Simon Brooke"}
[clojure.string :only [split trim triml]]) mw-parser.declarative
(:require [instaparse.core :as insta])) (: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 ;;;; mw-parser: a rule parser for MicroWorld.
"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 ;;;; This program is free software; you can redistribute it and/or
;; (1) rule text ;;;; modify it under the terms of the GNU General Public License
;; (2) cursor showing where in the rule text the error occurred ;;;; as published by the Free Software Foundation; either version 2
;; (3) the reason for the error ;;;; of the License, or (at your option) any later version.
(def bad-parse-error "I did not understand:\n'%s'\n%s\n%s") ;;;;
;;;; 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 (def grammar
;; in order to simplify translation into other natural languages, all ;; in order to simplify translation into other natural languages, all
;; TOKENS within the parser should be unambiguous ;; TOKENS within the parser should be unambiguous
"RULE := IF SPACE CONDITIONS SPACE THEN SPACE ACTIONS; "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; DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS;
CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS; CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS;
CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; CONDITION := WITHIN-CONDITION | NEIGHBOURS-CONDITION | PROPERTY-CONDITION;
WITHIN-CONDITION := NEIGHBOURS-CONDITION SPACE WITHIN SPACE NUMERIC-EXPRESSION; WITHIN-CONDITION := QUANTIFIER SPACE NEIGHBOURS SPACE WITHIN SPACE NUMBER SPACE IS SPACE PROPERTY-CONDITION-OR-EXPRESSION;
NEIGHBOURS-CONDITION := WITHIN-CONDITION | QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; 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; PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION | VALUE;
EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE;
SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE;
@ -31,7 +50,7 @@
RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION; RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION;
NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION; NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION;
NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER; 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; QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER;
QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER; QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER;
EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ;
@ -59,310 +78,41 @@
IS := 'is' | 'are' | 'have' | 'has'; IS := 'is' | 'are' | 'have' | 'has';
NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+'; NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+';
SYMBOL := #'[a-z]+'; SYMBOL := #'[a-z]+';
ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS ACTIONS := ACTION | ACTION SPACE AND SPACE ACTIONS
ACTION := SIMPLE-ACTION | PROBABLE-ACTION; ACTION := SIMPLE-ACTION | PROBABLE-ACTION;
PROBABLE-ACTION := VALUE SPACE 'chance in' SPACE VALUE SPACE SIMPLE-ACTION; PROBABLE-ACTION := VALUE SPACE CHANCE-IN SPACE VALUE SPACE SIMPLE-ACTION;
SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION;
BECOMES := 'should be' CHANCE-IN := 'chance in';
SPACE := #' *'" 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 (def parse-rule
"Parse the argument, assumed to be a string in the correct syntax, and return a parse tree." "Parse the argument, assumed to be a string in the correct syntax, and return a parse tree."
(insta/parser grammar)) (insta/parser grammar))
(defn explain-parse-error-reason
"Attempt to explain the reason for the parse error."
[reason]
(str "Expecting one of (" (apply str (map #(str (:expecting %) " ") reason)) ")"))
(defn parser-error-to-map
[parser-error]
(let [m (reduce (fn [map item](merge map {(first item)(second item)})) {} parser-error)
reason (map
#(reduce (fn [map item] (merge {(first item) (second item)} map)) {} %)
(:reason m))]
(merge m {:reason reason})))
(defn throw-parse-exception
"Construct a helpful error message from this `parser-error`, and throw an exception with that message."
[parser-error]
(assert (coll? parser-error) "Expected a paser error structure?")
(let
[
;; the error structure is a list, such that each element is a list of two items, and
;; the first element in each sublist is a keyword. Easier to work with it as a map
error-map (parser-error-to-map parser-error)
text (:text error-map)
reason (explain-parse-error-reason (:reason error-map))
;; rules have only one line, by definition; we're interested in the column
column (if (:column error-map)(:column error-map) 0)
;; create a cursor to point to that column
cursor (apply str (reverse (conj (repeat column " ") "^")))
message (format bad-parse-error text cursor reason)
]
(throw (Exception. message))))
(defn compile-rule (defn compile-rule
"Compile this `rule`, assumed to be a string with appropriate syntax, into a function of two arguments, "Parse this `rule-text`, a string conforming to the grammar of MicroWorld rules,
a `cell` and a `world`, having the same semantics." into Clojure source, and then compile it into an anonymous
[rule] function object, getting round the problem of binding mw-engine.utils in
(assert (string? rule)) the compiling environment. If `return-tuple?` is present and true, return
(let [tree (simplify (parse-rule rule))] a list comprising the anonymous function compiled, and the function from
(if (rule? tree) (eval (generate tree)) which it was compiled.
(throw-parse-exception tree))))
Throws an exception if parsing fails."
([rule-text return-tuple?]
(assert (string? rule-text))
(let [rule (trim rule-text)
tree (ps/simplify (parse-rule rule))
afn (if (rule? tree) (eval (pg/generate tree))
;; else
(pe/throw-parse-exception tree))]
(if return-tuple?
(list afn rule)
;; else
afn)))
([rule-text]
(compile-rule rule-text false)))

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"))))) (as-file "resources/rules.txt")))))
"all compiled rules should be ifns") "all compiled rules should be ifns")
)) ))

82
test/mw_parser/declarative_test.clj
View file

@ -2,7 +2,8 @@
(:use clojure.pprint (:use clojure.pprint
mw-engine.core mw-engine.core
mw-engine.world mw-engine.world
mw-engine.utils) mw-engine.utils
mw-parser.utils)
(:require [clojure.test :refer :all] (:require [clojure.test :refer :all]
[mw-parser.declarative :refer :all])) [mw-parser.declarative :refer :all]))
@ -32,51 +33,6 @@
(is (rule? (parse-rule "if 6 neighbours have state equal to water then state should be village"))) (is (rule? (parse-rule "if 6 neighbours have state equal to water then state should be village")))
)) ))
(deftest expressions-tests
(testing "Generating primitive expressions."
(is (generate '(:NUMERIC-EXPRESSION (:NUMBER "50"))) 50)
(is (generate '(:NUMERIC-EXPRESSION (:SYMBOL "sealevel")))
'(:sealevel cell))
))
(deftest lhs-generators-tests
(testing "Generating left-hand-side fragments of rule functions from appropriate fragments of parse trees"
(is (generate
'(:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest")))
'(= (:state cell) :forest))
(is (generate
'(:PROPERTY-CONDITION (:SYMBOL "fertility") [:EQUIVALENCE [:IS "is"]] (:NUMBER "10")))
'(= (:fertility cell) 10))
(is (generate '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:COMPARATIVE [:LESS "less"]] (:NUMBER "10")))
'(< (:fertility cell) 10))
(is (generate '(:PROPERTY-CONDITION (:SYMBOL "fertility") [:COMPARATIVE [:MORE "more"]] (:NUMBER "10")))
'(> (:fertility cell) 10))
(is (generate '(:CONJUNCT-CONDITION (:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest")) (:AND "and") (:PROPERTY-CONDITION (:SYMBOL "fertility") [:EQUIVALENCE [:IS "is"]] (:NUMBER "10"))))
'(and (= (:state cell) :forest) (= (:fertility cell) 10)))
(is (generate '(:DISJUNCT-CONDITION (:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest")) (:OR "or") (:PROPERTY-CONDITION (:SYMBOL "fertility") [:EQUIVALENCE [:IS "is"]] (:NUMBER "10"))))
'(or (= (:state cell) :forest) (= (:fertility cell) 10)))
(is (generate '(:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:DISJUNCT-EXPRESSION (:IN "in") (:DISJUNCT-VALUE (:SYMBOL "grassland") (:OR "or") (:DISJUNCT-VALUE (:SYMBOL "pasture") (:OR "or") (:DISJUNCT-VALUE (:SYMBOL "heath")))))))
'(let [value (:state cell)] (some (fn [i] (= i value)) (quote (:grassland :pasture :heath)))))
(is (generate '(:PROPERTY-CONDITION (:SYMBOL "altitude") [:EQUIVALENCE [:IS "is"]] (:RANGE-EXPRESSION (:BETWEEN "between") (:NUMERIC-EXPRESSION (:NUMBER "50")) (:AND "and") (:NUMERIC-EXPRESSION (:NUMBER "100")))))
'(let [lower (min 50 100) upper (max 50 100)] (and (>= (:altitude cell) lower) (<= (:altitude cell) upper))))
))
(deftest rhs-generators-tests
(testing "Generating right-hand-side fragments of rule functions from appropriate fragments of parse trees"
(is (generate
'(:SIMPLE-ACTION (:SYMBOL "state") (:BECOMES "should be") (:SYMBOL "climax")))
'(merge cell {:state :climax}))
(is (generate
'(:SIMPLE-ACTION (:SYMBOL "fertility") (:BECOMES "should be") (:NUMBER "10")))
'(merge cell {:fertility 10}))
))
(deftest full-generation-tests
(testing "Full rule generation from pre-parsed tree"
(is (generate '(:RULE (:IF "if") (:PROPERTY-CONDITION (:SYMBOL "state") [:EQUIVALENCE [:IS "is"]] (:SYMBOL "forest")) (:SIMPLE-ACTION (:SYMBOL "state") (:BECOMES "should be") (:SYMBOL "climax"))))
'(fn [cell world] (if (= (:state cell) :forest) (merge cell {:state :climax}))))
))
(deftest exception-tests (deftest exception-tests
(testing "Constructions which should cause exceptions to be thrown" (testing "Constructions which should cause exceptions to be thrown"
@ -96,6 +52,7 @@
"Exception thrown on attempt to set 'y'") "Exception thrown on attempt to set 'y'")
)) ))
(deftest correctness-tests (deftest correctness-tests
;; these are, in so far as possible, the same as the correctness-tests in core-tests - i.e., the two compilers ;; these are, in so far as possible, the same as the correctness-tests in core-tests - i.e., the two compilers
;; compile the same language. ;; compile the same language.
@ -180,14 +137,13 @@
(is (nil? (apply afn (list {:altitude 200} nil))) (is (nil? (apply afn (list {:altitude 200} nil)))
"Rule does not fire when condition is not met"))) "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"
;; (testing "Property is more than property" (let [afn (compile-rule "if wolves are more than deer then deer should be 0")]
;; (let [afn (compile-rule "if wolves are more than deer then deer should be 0")] (is (= (apply afn (list {:deer 2 :wolves 3} nil))
;; (is (= (apply afn (list {:deer 2 :wolves 3} nil)) {:deer 0 :wolves 3})
;; {:deer 0 :wolves 3}) "Rule fires when condition is met")
;; "Rule fires when condition is met") (is (nil? (apply afn (list {:deer 3 :wolves 2} nil)))
;; (is (nil? (apply afn (list {:deer 3 :wolves 2} nil))) "Rule does not fire when condition is not met")))
;; "Rule does not fire when condition is not met")))
(testing "Property is less than numeric-value" (testing "Property is less than numeric-value"
(let [afn (compile-rule "if altitude is less than 10 then state should be water")] (let [afn (compile-rule "if altitude is less than 10 then state should be water")]
@ -231,6 +187,7 @@
"Middle cell has eight neighbours, so rule does not fire."))) "Middle cell has eight neighbours, so rule does not fire.")))
(testing "Number neighbours have property more than numeric-value" (testing "Number neighbours have property more than numeric-value"
;; 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") (let [afn (compile-rule "if 3 neighbours have altitude more than 10 then state should be beach")
world (transform-world world (transform-world
(make-world 3 3) (make-world 3 3)
@ -432,12 +389,12 @@
"Addition is executed"))) "Addition is executed")))
(testing "Arithmetic action: addition of property value" (testing "Arithmetic action: addition of property value"
(let [afn (compile-rule "if state is climax then fertility should be fertility + leaf-fall")] (let [afn (compile-rule "if state is climax then fertility should be fertility + leaffall")]
(is (= (:fertility (is (= (:fertility
(apply afn (apply afn
(list {:state :climax (list {:state :climax
:fertility 0 :fertility 0
:leaf-fall 1} nil))) :leaffall 1} nil)))
1) 1)
"Addition is executed"))) "Addition is executed")))
@ -515,3 +472,16 @@
(is (nil? (apply afn (list {:x 0 :y 1} world))) (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.")) "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}))))
))