Started work on generating code from flow rules.

src/mw_parser/core.clj

@@ -4,10 +4,9 @@
             declarative parser, q.v."
       :author "Simon Brooke"}
  mw-parser.core
-  (:use mw-engine.utils
+  (:require [clojure.string :only [split trim triml]]
-        [clojure.string :only [split trim triml]])
+            [mw-engine.utils :refer [member?]])
-  (:gen-class)
+  (: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
+    (cond expect-int (parse-property-int tokens)
-          (parse-property-int tokens)
+          :else (parse-token-value tokens))))
-          true (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))
+                                  (list (symbol operator)
-                                        (cond
+                                        (list 'get-int 'cell (keyword prop2))
-                                          (re-matches re-number value) (read-string value)
+                                        (if
-                                          true (list 'get-int 'cell (keyword value)))))}) rest]))
+                                         (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,13 +390,13 @@
     (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"
   [previous [n CHANCE IN m & tokens]]
   (cond
-    (and (= CHANCE "chance")(= IN "in"))
+    (and (= CHANCE "chance") (= IN "in"))
     (let [[action remainder] (parse-actions previous tokens)]
       (cond action
             [(list 'cond
@@ -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
+  (if
-   (string? line)
+   (string? line) (let [rule (parse-rule (split (triml line) #"\s+"))]
-   (let [rule (parse-rule (split (triml line) #"\s+"))]
+                    (if rule rule
-     (cond rule rule
+                        (throw (Exception. (format bad-parse-error line)))))
-       true (throw (Exception. (format bad-parse-error line)))))
-   true
    (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
+     (if
-          (and afn return-tuple?)(list afn (trim rule-text))
+      (and afn return-tuple?)
-          true afn))))
+       (list afn (trim rule-text))
+       afn)))
   ([rule-text]
    (compile-rule rule-text false)))

src/mw_parser/declarative.clj

@@ -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]]
+  (:require [clojure.string :refer [join split trim]]
-            [clojure.string :refer [join 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

src/mw_parser/flow.clj

@@ -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]]
+  (:require [clojure.string :refer [join]]))
-            [mw-parser.declarative :refer [build-parser]]
-            [mw-parser.simplify :refer [simplify-second-of-two]]))
 
 (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))
-

src/mw_parser/generate.clj

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

test/mw_parser/bulk_test.clj

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

test/mw_parser/core_test.clj

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

test/mw_parser/declarative_test.clj

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