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

Started work on generating code from flow rules.

Browse source
This commit is contained in:
Simon Brooke 2023-07-12 23:43:59 +01:00
parent 256f9efd5e
commit 2a5d598f28
7 changed files with 649 additions and 655 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

91
src/mw_parser/core.clj
View file

@ -4,10 +4,9 @@
declarative parser, q.v."
:author "Simon Brooke"}
mw-parser.core
(:use mw-engine.utils
[clojure.string :only [split trim triml]])
(:gen-class)
)
(:require [clojure.string :only [split trim triml]]
[mw-engine.utils :refer [member?]])
(:gen-class))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
@ -81,7 +80,7 @@
(cond
(re-matches re-number token) (read-string token)
(keyword? token) token
true (keyword token)))
:else (keyword token)))
;; Generally all functions in this file with names beginning 'parse-' take a
;; sequence of tokens (and in some cases other optional arguments) and return a
@ -97,23 +96,23 @@
(defn parse-numeric-value
"Parse a number."
[[value & remainder]]
(if (and value (re-matches re-number value)) [(read-string value) remainder]))
(when (and value (re-matches re-number value)) [(read-string value) remainder]))
(defn parse-property-int
"Parse a token assumed to be the name of a property of the current cell,
whose value is assumed to be an integer."
[[value & remainder]]
(if value [(list 'get-int 'cell (keyword value)) remainder]))
(when value [(list 'get-int 'cell (keyword value)) remainder]))
(defn parse-property-value
"Parse a token assumed to be the name of a property of the current cell."
[[value & remainder]]
(if value [(list (keyword value) 'cell) remainder]))
(when value [(list (keyword value) 'cell) remainder]))
(defn parse-token-value
"Parse a token assumed to be a simple token value."
[[value & remainder]]
(if value [(keyword value) remainder]))
(when value [(keyword value) remainder]))
(defn parse-simple-value
"Parse a value from the first of these `tokens`. If `expect-int` is true, return
@ -121,9 +120,8 @@
([tokens expect-int]
(or
(parse-numeric-value tokens)
(cond expect-int
(parse-property-int tokens)
true (parse-token-value tokens))))
(cond expect-int (parse-property-int tokens)
:else (parse-token-value tokens))))
([tokens]
(parse-simple-value tokens false)))
@ -143,7 +141,7 @@
(cond seek-others
(let [[others remainder] (parse-disjunct-value tokens expect-int)]
[(cons value others) remainder])
true
:else
[(list value) tokens]))))
(defn parse-value
@ -159,7 +157,7 @@
(defn parse-member-condition
"Parses a condition of the form '[property] in [value] or [value]...'"
[[property IS IN & rest]]
(if (and (member? IS '("is" "are")) (= IN "in"))
(when (and (member? IS '("is" "are")) (= IN "in"))
(let [[l remainder] (parse-disjunct-value (cons "in" rest) false)]
[(list 'member? (list (keyword property) 'cell) (list 'quote l)) remainder])))
@ -192,12 +190,11 @@
'x is between y and z', 'x is more than y' or 'x is less than y'.
It is necessary to disambiguate whether value is a numeric or keyword."
[[property IS value & rest]]
(cond
(when
(member? IS '("is" "are"))
(let [tokens (cons property (cons value rest))]
(cond
(re-matches re-number value) [(list '= (list 'get-int 'cell (keyword property)) (read-string value)) rest]
value [(list '= (list (keyword property) 'cell) (keyword value)) rest]))))
value [(list '= (list (keyword property) 'cell) (keyword value)) rest])))
(defn- parse-not-condition
"Parse the negation of a simple condition."
@ -254,8 +251,7 @@
value remainder > dist)
(and (= comp1 "less") (= comp2 "than"))
(gen-neighbours-condition comparator quantity property
value remainder < dist)
))))))
value remainder < dist)))))))
(defn parse-some-neighbours-condition
[[SOME NEIGHBOURS & rest]]
@ -292,8 +288,7 @@
dist)
(and (= comp1 "less") (= comp2 "than"))
(gen-neighbours-condition '= quantity property value remainder <
dist)
))))))
dist)))))))
(defn parse-neighbours-condition
"Parse conditions referring to neighbours"
@ -301,8 +296,7 @@
(or
(parse-simple-neighbours-condition tokens)
(parse-comparator-neighbours-condition tokens)
(parse-some-neighbours-condition tokens)
))
(parse-some-neighbours-condition tokens)))
(defn parse-simple-condition
"Parse conditions of the form '[property] [comparison] [value]'."
@ -320,7 +314,7 @@
"Parse '... or [condition]' from `tokens`, where `left` is the already parsed first disjunct."
[left tokens]
(let [partial (parse-conditions tokens)]
(if partial
(when partial
(let [[right remainder] partial]
[(list 'or left right) remainder]))))
@ -328,7 +322,7 @@
"Parse '... and [condition]' from `tokens`, where `left` is the already parsed first conjunct."
[left tokens]
(let [partial (parse-conditions tokens)]
(if partial
(when partial
(let [[right remainder] partial]
[(list 'and left right) remainder]))))
@ -336,17 +330,17 @@
"Parse conditions from `tokens`, where conditions may be linked by either 'and' or 'or'."
[tokens]
(let [partial (parse-simple-condition tokens)]
(if partial
(when partial
(let [[left [next & remainder]] partial]
(cond
(= next "and") (parse-conjunction-condition left remainder)
(= next "or") (parse-disjunction-condition left remainder)
true partial)))))
:else partial)))))
(defn- parse-left-hand-side
"Parse the left hand side ('if...') of a production rule."
[[IF & tokens]]
(if
(when
(= IF "if")
(parse-conditions tokens)))
@ -363,10 +357,13 @@
(member? operator '("+" "-" "*" "/")))
[(list 'merge (or previous 'cell)
{(keyword prop1) (list 'int
(list (symbol operator) (list 'get-int 'cell (keyword prop2))
(cond
(re-matches re-number value) (read-string value)
true (list 'get-int 'cell (keyword value)))))}) rest]))
(list (symbol operator)
(list 'get-int 'cell (keyword prop2))
(if
(re-matches re-number value)
(read-string value)
(list 'get-int 'cell (keyword value)))))})
rest]))
(defn- parse-set-action
"Parse actions of the form '[property] should be [value].'"
@ -377,7 +374,10 @@
(Exception. reserved-properties-error))
(and (= SHOULD "should") (= BE "be"))
[(list 'merge (or previous 'cell)
{(keyword property) (cond (re-matches re-number value) (read-string value) true (keyword value))}) rest]))
{(keyword property) (if
(re-matches re-number value)
(read-string value)
(keyword value))}) rest]))
(defn- parse-simple-action [previous tokens]
(or (parse-arithmetic-action previous tokens)
@ -390,7 +390,7 @@
(cond left
(cond (= (first remainder) "and")
(parse-actions left (rest remainder))
true (list left)))))
:else (list left)))))
(defn- parse-probability
"Parse a probability of an action from this collection of tokens"
@ -409,7 +409,7 @@
(defn- parse-right-hand-side
"Parse the right hand side ('then...') of a production rule."
[[THEN & tokens]]
(if (= THEN "then")
(when (= THEN "then")
(or
(parse-probability nil tokens)
(parse-actions nil tokens))))
@ -420,15 +420,13 @@
Throws an exception if parsing fails."
[line]
(cond
(string? line)
(let [rule (parse-rule (split (triml line) #"\s+"))]
(cond rule rule
true (throw (Exception. (format bad-parse-error line)))))
true
(if
(string? line) (let [rule (parse-rule (split (triml line) #"\s+"))]
(if rule rule
(throw (Exception. (format bad-parse-error line)))))
(let [[left remainder] (parse-left-hand-side line)
[right junk] (parse-right-hand-side remainder)]
(cond
(when
;; there should be a valide left hand side and a valid right hand side
;; there shouldn't be anything left over (junk should be empty)
(and left right (empty? junk))
@ -444,11 +442,10 @@
Throws an exception if parsing fails."
([rule-text return-tuple?]
(do
(use 'mw-engine.utils)
(let [afn (eval (parse-rule rule-text))]
(cond
(and afn return-tuple?)(list afn (trim rule-text))
true afn))))
(if
(and afn return-tuple?)
(list afn (trim rule-text))
afn)))
([rule-text]
(compile-rule rule-text false)))

24
src/mw_parser/declarative.clj
View file

@ -1,9 +1,10 @@
(ns ^{:doc "A very simple parser which parses production rules."
:author "Simon Brooke"}
mw-parser.declarative
(:require [instaparse.core :refer [parser]]
[clojure.string :refer [join trim]]
(:require [clojure.string :refer [join split trim]]
[instaparse.core :refer [parser]]
[mw-parser.errors :refer [throw-parse-exception]]
[mw-parser.flow :refer [flow-grammar]]
[mw-parser.generate :refer [generate]]
[mw-parser.simplify :refer [simplify]]
[mw-parser.utils :refer [rule?]]
@ -71,8 +72,7 @@
"SPACE := #'\\s+';"
"VALUE := SYMBOL | NUMBER;"
"VALUE := SYMBOL | NUMBER;"
"WITHIN-CONDITION := QUANTIFIER SPACE NEIGHBOURS SPACE WITHIN SPACE NUMBER SPACE IS SPACE PROPERTY-CONDITION-OR-EXPRESSION;"
]))
"WITHIN-CONDITION := QUANTIFIER SPACE NEIGHBOURS SPACE WITHIN SPACE NUMBER SPACE IS SPACE PROPERTY-CONDITION-OR-EXPRESSION;"]))
(def keywords-en
"English language keyword literals used in rules - both in production
@ -132,6 +132,22 @@
"Parse the argument, assumed to be a string in the correct syntax, and return a parse tree."
(build-parser rule-grammar))
(def parse-flow
"Parse the argument, assumed to be a string in the correct syntax, and return a parse tree."
(build-parser flow-grammar))
(defn parse
"Top level parser function: parse this `text` as either a production or a flow rule;
return a raw parse tree."
[^String rule-text]
(let [text (trim rule-text)]
(when-not (zero? (count text))
(case (first (split text #"\s+"))
"if" (parse-rule text)
"flow" (parse-flow text)
";;" nil
(throw (ex-info "Rule text was not recognised" {:text text}))))))
(defn compile-rule
"Parse this `rule-text`, a string conforming to the grammar of MicroWorld rules,
into Clojure source, and then compile it into an anonymous

36
src/mw_parser/flow.clj
View file

@ -1,9 +1,7 @@
(ns ^{:doc "A very simple parser which parses flow rules."
:author "Simon Brooke"}
mw-parser.flow
(:require [clojure.string :refer [join]]
[mw-parser.declarative :refer [build-parser]]
[mw-parser.simplify :refer [simplify-second-of-two]]))
(:require [clojure.string :refer [join]]))
(def flow-grammar
"Grammar for flow rules.
@ -21,7 +19,7 @@
The basic rule I want to be able to compile at this stage is the 'mutual
aid' rule:
`flow 1 food from house having food > 1 to house with least food within 2`
`flow 1 food from house to house within 2 with least food`
"
(join "\n" ["FLOW-RULE := FLOW SPACE QUANTITY SPACE PROPERTY SPACE FROM SPACE SOURCE SPACE TO-HOW SPACE DESTINATION;"
"PERCENTAGE := NUMBER #'%';"
@ -35,33 +33,3 @@
"TO-HOW := TO | TO-EACH | TO-FIRST;"
"TO-EACH := TO SPACE EACH | TO SPACE ALL;"
"TO-FIRST := TO SPACE FIRST"]))
(def parse-flow
"Parse the argument, assumed to be a string in the correct syntax, and return a parse tree."
(build-parser flow-grammar))
(defn simplify-flow
[tree]
(if (coll? tree)
(case (first tree)
:CONDITION (simplify-second-of-two tree)
:CONDITIONS (simplify-second-of-two tree)
:DETERMINER (simplify-second-of-two tree)
;; :DETERMINER-CONDITION (simplify-determiner-condition tree)
:EXPRESSION (simplify-second-of-two tree)
:FLOW nil
;; :FLOW-CONDITIONS (simplify-second-of-two tree)
:PROPERTY (simplify-second-of-two tree)
:PROPERTY-CONDITION-OR-EXPRESSION (simplify-second-of-two tree)
:SPACE nil
:QUANTITY (simplify-second-of-two tree)
:STATE (list :PROPERTY-CONDITION
(list :SYMBOL "state")
'(:QUALIFIER
(:EQUIVALENCE
(:IS "is")))
(list :EXPRESSION
(list :VALUE (second tree))))
(remove nil? (map simplify-flow tree)))
tree))

16
src/mw_parser/generate.clj
View file

@ -280,9 +280,23 @@
;;; (fn [cell world])
;;; (if (= (:state cell) (or (:house cell) :house))
(defmacro flow-rule
[source property quantity-frag destinations]
`(fn [cell world]
(when (and ~source (pos? cell ~property))
(map
(fn [d] {:source (select-keys cell [:x :y])
:destination (select-keys d [:x :y])
:property ~property
:quantity ~quantity-frag})
~destinations))))
(defn generate-flow
[tree]
(assert-type tree :FLOW-RULE))
(assert-type tree :FLOW-RULE)
(let [clauses (reduce #(assoc %1 (first %2) %2) {} (rest tree))]
(list 'fn ['cell 'world]
(list 'when (generate (:SOURCE clauses))))))
;;; Top level; only function anything outside this file (except tests) should
;;; really call.

6
test/mw_parser/bulk_test.clj
View file

@ -1,7 +1,7 @@
(ns mw-parser.bulk-test
(:use clojure.java.io)
(:require [clojure.test :refer :all]
[mw-parser.bulk :refer :all]))
(:require [clojure.java.io :refer [as-file]]
[clojure.test :refer [deftest is testing]]
[mw-parser.bulk :refer [compile-file parse-file]]))
(deftest bulk-parsing-test
(testing "Bulk (file) parsing and compilation"

22
test/mw_parser/core_test.clj
View file

@ -29,8 +29,7 @@
(is (= (parse-property-value '()) nil)
"if there's nothing to parse, return nil")
(is (= (first (parse-property-value '("this" "and" "that"))) '(:this cell))
"Parsing a property value returns a code function to pull its value off the current cell")
))
"Parsing a property value returns a code function to pull its value off the current cell")))
(deftest rules-tests
@ -45,8 +44,7 @@
(is (parse-rule "if 6 neighbours have state equal to water then state should be village"))
(is (parse-rule "if state is in grassland or pasture or heath and 4 neighbours are water then state should be village"))
(is (parse-rule "if state is climax and some neighbours have state equal to fire then 3 chance in 5 state should be fire"))
(is (parse-rule "if state is pasture and more than 3 neighbours have state equal to scrub then state should be scrub"))
))
(is (parse-rule "if state is pasture and more than 3 neighbours have state equal to scrub then state should be scrub"))))
(deftest exception-tests
(testing "Constructions which should cause exceptions to be thrown"
@ -68,8 +66,7 @@
(is (thrown? Exception (compile-rule "if state is new then x should be heath"))
"Can't set x property to symbol, as this would break the world")
(is (thrown? Exception (compile-rule "if state is new then y should be heath"))
"Can't set y property to symbol, as this would break the world")
))
"Can't set y property to symbol, as this would break the world")))
(deftest correctness-tests
(testing "Simplest possible rule"
@ -109,7 +106,15 @@
{:state :grassland})
"Rule fires when condition is met")))
(testing "Can't set x or y properties")
(testing "Can't set x or y properties"
(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 #"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'"))
(testing "Simple list membership rule"
(let [afn (compile-rule "if state is in heath or scrub or forest then state should be climax")]
@ -238,8 +243,7 @@
(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."))
)
"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")

13
test/mw_parser/declarative_test.clj
View file

@ -28,8 +28,7 @@
(is (rule? (parse-rule "if state is pasture and more than 3 neighbours have state equal to scrub then state should be scrub")))
(is (rule? (parse-rule "if state is in grassland or pasture or heath and 4 neighbours have state equal to water then state should be village")))
(is (rule? (parse-rule "if state is grassland and 4 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")))
))
(is (rule? (parse-rule "if 6 neighbours have state equal to water then state should be village")))))
(deftest exception-tests
@ -47,8 +46,7 @@
(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'")))
(deftest correctness-tests
@ -237,8 +235,7 @@
(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."))
)
"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")
@ -468,8 +465,7 @@
(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."))
))
"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"
@ -482,4 +478,3 @@
"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."))))