Flow rule generation very nearly correct!

Not all tests pass; additional conditions are not yet evaluated.

src/mw_parser/core.clj

@@ -4,7 +4,7 @@
             declarative parser, q.v."
       :author "Simon Brooke"}
  mw-parser.core
-  (:require [clojure.string :only [split trim triml]]
+  (:require [clojure.string :refer [split trim triml]]
             [mw-engine.utils :refer [member?]])
   (:gen-class))
 
@@ -102,7 +102,7 @@
   "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]]
-  (when value [(list 'get-int 'cell (keyword value)) remainder]))
+  (when value [(list 'mw-engine.utils/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."

src/mw_parser/flow.clj

@@ -25,11 +25,13 @@
               "PERCENTAGE := NUMBER #'%';"
               "QUANTITY := PERCENTAGE | NUMBER | EXPRESSION | SOME;"
               "SOURCE := STATE | STATE SPACE WITH SPACE CONDITIONS;"
-              "DESTINATION := STATE | STATE SPACE WITH SPACE FLOW-CONDITIONS | STATE SPACE WITHIN SPACE VALUE SPACE WITH SPACE FLOW-CONDITIONS;"
+              "DESTINATION := TARGET | TARGET SPACE WITH SPACE FLOW-CONDITIONS;"
               "DETERMINER := MOST | LEAST;"
-              "DETERMINER-CONDITION := DETERMINER SPACE PROPERTY | DETERMINER SPACE PROPERTY;"
+              "DETERMINER-CONDITION := DETERMINER SPACE PROPERTY;"
               "FLOW-CONDITIONS := DETERMINER-CONDITION | CONDITIONS"
+              "RANGE := WITHIN SPACE VALUE;"
               "STATE := SYMBOL;"
+              "TARGET := STATE | STATE SPACE RANGE;"
               "TO-HOW := TO | TO-EACH | TO-FIRST;"
               "TO-EACH := TO SPACE EACH | TO SPACE ALL;"
               "TO-FIRST := TO SPACE FIRST"]))

src/mw_parser/generate.clj

@@ -1,10 +1,8 @@
 (ns ^{:doc "Generate Clojure source from simplified parse trees."
       :author "Simon Brooke"}
  mw-parser.generate
-  (:require [clojure.pprint :refer [pprint]]
+  (:require [mw-parser.errors :as pe]
-            [clojure.tools.trace :refer [deftrace]]
+            [mw-parser.utils :refer [assert-type search-tree TODO]]))
-            [mw-parser.utils :refer [assert-type TODO]]
-            [mw-parser.errors :as pe]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -233,7 +231,8 @@
          (list 'count
                (list 'remove 'false?
                      (list 'map (list 'fn ['cell] property-condition)
-                           (list 'mw-engine.utils/get-neighbours 'world 'cell distance)))) quantity))
+                           (list 'mw-engine.utils/get-neighbours 'world 'cell distance))))
+         quantity))
   ([comp1 quantity property-condition]
    (generate-neighbours-condition comp1 quantity property-condition 1)))
 
@@ -253,7 +252,11 @@
          distance (generate (nth tree 4))
          pc (generate (nth tree 6))]
      (case quantifier-type
-       :NUMBER (generate-neighbours-condition '= (read-string (second (second quantifier))) pc distance)
+       :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))
@@ -280,23 +283,100 @@
 ;;; (fn [cell world])
 ;;;    (if (= (:state cell) (or (:house cell) :house))
 
-(defmacro flow-rule
+(defn flow-rule
+  "Generate a flow rule for this `quantity` of this `property` from this 
+   `source` to this `destination`."
   [source property quantity-frag destinations]
-  `(fn [cell world]
+  (vary-meta
-     (when (and ~source (pos? cell ~property))
+   (list 'fn ['cell 'world]
-       (map 
+         (list 'when (list 'and source (list 'pos? 'cell property))
-       (fn [d] {:source (select-keys cell [:x :y])
+               (list 'map
-                :destination (select-keys d [:x :y])
+                     (list 'fn ['d]
-                :property ~property
+                          {:source (list 'select-keys 'cell [:x :y])
-                :quantity ~quantity-frag})
+                           :destination (list 'select-keys 'd [:x :y])
-        ~destinations))))
+                           :property property
+                           :quantity quantity-frag})
+                     destinations)))
+   merge
+   {:rule-type
+    :flow}))
+
+(defn generate-quantity-accessor
+  "Generate a code fragment which will generate the appropriate quantity of
+   the `property` specified in a rule, from this `q-clause`."
+  [q-clause property]
+  (case (first q-clause)
+    ;; TODO :EXPRESSION still needed
+    :NUMBER (generate q-clause)
+    :PERCENTAGE (let [multiplier (/ (generate (second q-clause)) 100)]
+                  (list '* multiplier (list property 'cell)))
+    :SOME (list 'rand (list property 'cell))
+    (throw (ex-info
+            (format "Unexpected QUANTITY type: `%s`" (first q-clause))
+            {:clause q-clause
+             :property property}))))
+
+(defn generate-target-state-filter
+  [clause targets-frag]
+  (assert-type clause :DESTINATION)
+  (list 'filter
+        (list 'fn ['cell]
+              (generate-property-condition
+               (search-tree (search-tree clause :TARGET)
+                            :PROPERTY-CONDITION)))
+        targets-frag))
+
+(defn generate-dest-accessor
+  [clause]
+  (let [dc (search-tree clause :DETERMINER-CONDITION)
+        range (search-tree clause :RANGE)
+        distance (if range (generate (nth range 2)) 1)]
+    (list 'let ['candidates
+                (generate-target-state-filter
+                 clause
+                 (list 'mw-engine.utils/get-neighbours 'world 'cell distance))]
+          (if dc
+            (list 'list
+                  (let [determiner (first (second (search-tree dc :DETERMINER)))
+                        prop (generate (nth dc 2))]
+                    (case determiner
+                      :LEAST (list 'mw-engine.utils/get-least-cell 'candidates prop)
+                      :MOST (list 'mw-engine.utils/get-most-cell 'candidates prop))))
+            'candidates))))
+;; (fn
+;;   [cell world]
+;;   (when
+;;    (and (= (:state cell) (or (:house cell) :house)) (pos? cell :food))
+;; (map
+;;    (fn
+;;      [d]
+;;      (assoc
+;;       {}
+;;       :source
+;;       (select-keys cell [:x :y])
+;;       :destination
+;;       (select-keys d [:x :y])
+;;       :property
+;;       :food
+;;       :quantity
+;;       (* 1/10 (:food cell)))
+;;      {})
+;;    (let
+;;     [candidates
+;;      (filter
+;;       (fn [cell] (= (:state cell) (or (:house cell) :house)))
+;;       (mw-engine.utils/get-neighbours world cell 2))]
+;;      (list (mw-engine.utils/get-least-cell candidates :food))))))
 
 (defn generate-flow
   [tree]
   (assert-type tree :FLOW-RULE)
-  (let [clauses (reduce #(assoc %1 (first %2) %2) {} (rest tree))]
+  (let [clauses (reduce #(assoc %1 (first %2) %2) {} (rest tree))
-    (list 'fn ['cell 'world] 
+        source-accessor (generate (:SOURCE clauses))
-          (list 'when (generate (:SOURCE clauses))))))
+        property (generate (:SYMBOL clauses))
+        quantity (generate-quantity-accessor (second (:QUANTITY clauses)) property)
+        dest-accessor (generate-dest-accessor (:DESTINATION clauses))]
+    (flow-rule source-accessor property quantity dest-accessor)))
 
 ;;; Top level; only function anything outside this file (except tests) should 
 ;;; really call.
@@ -333,8 +413,10 @@
       :PROPERTY (list (generate (second tree)) 'cell) ;; dubious - may not be right
       :PROPERTY-CONDITION (generate-property-condition tree)
       :QUALIFIER (generate-qualifier tree)
+      :QUANTITY (generate (second tree))
       :RULE (generate-rule tree)
       :SIMPLE-ACTION (generate-simple-action tree)
+      :SOURCE (generate (second tree))
       :SYMBOL (keyword (second tree))
       :VALUE (generate (second tree))
       :WITHIN-CONDITION (generate-within-condition tree)

src/mw_parser/simplify.clj

@@ -1,6 +1,7 @@
 (ns ^{:doc "Simplify a parse tree."
       :author "Simon Brooke"}
- mw-parser.simplify)
+ mw-parser.simplify 
+  (:require [mw-parser.utils :refer [search-tree]]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;
@@ -72,16 +73,29 @@
       :CONDITIONS (simplify-second-of-two tree)
       :DISJUNCT-EXPRESSION (simplify-chained-list tree :DISJUNCT-VALUE :VALUE)
       :EXPRESSION (simplify-second-of-two tree)
+      :FLOW-CONDITIONS (simplify-second-of-two tree)
       :IN nil
       :PROPERTY (simplify-second-of-two tree)
       :PROPERTY-CONDITION-OR-EXPRESSION (simplify-second-of-two tree)
       :OR nil
       :SPACE nil
+      :STATE (list :PROPERTY-CONDITION
+                   (list :SYMBOL "state")
+                   '(:QUALIFIER
+                     (:EQUIVALENCE
+                      (:IS "is")))
+                   (list :EXPRESSION
+                         (list :VALUE (second tree))))
       :THEN nil
       :VALUE (simplify-second-of-two tree)
       (remove nil? (map simplify tree)))
     tree))
 
+;; OK, there is a major unresolved problem. If there is a determiner condition,
+;; the tree as parsed from natural language is the wrong shape, and we're 
+;; going to have to restructure it somewhere to being the determiner upstream
+;; of the property conditions. It *may* be possible to do that in `generate`.
+
 (defn simplify-determiner-condition
   [tree]
   (apply vector

src/mw_parser/utils.clj

@@ -49,7 +49,9 @@
   "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)))))
+          (throw (ex-info (format "Expected a %s fragment" type)
+                          {:actual tree-fragment
+                           :expected type}))))
 
 
 (defn search-tree

test/mw_parser/core_test.clj

@@ -15,7 +15,7 @@
     (is (= (first (parse-simple-value '("this" "and" "that"))) :this)
         "or else just a keyword")
     (is (= (first (parse-simple-value '("this" "and" "that") true))
-           '(get-int cell :this))
+           '(mw-engine.utils/get-int cell :this))
         "...unless an integer is explicitly sought, in which case it should be something which gets an integer from the current cell")
     (is (= (parse-value '()) nil)
         "if there's nothing to parse, return nil")
@@ -24,7 +24,7 @@
     (is (= (first (parse-value '("this" "and" "that"))) :this)
         "or else just a keyword")
     (is (= (first (parse-value '("this" "and" "that") true))
-           '(get-int cell :this))
+           '(mw-engine.utils/get-int cell :this))
         "...unless an integer is explicitly sought, in which case it should be something which gets an integer from the current cell")
     (is (= (parse-property-value '()) nil)
         "if there's nothing to parse, return nil")

test/mw_parser/flow_test.clj

@@ -1,7 +1,8 @@
 (ns mw-parser.flow-test
   (:require ;; [clojure.pprint :as pprint]
             [clojure.test :refer [deftest is testing]] ;; [mw-engine.core :refer [transform-world]]
-            [mw-parser.flow :refer [parse-flow simplify-flow]]))
+            [mw-parser.declarative :refer [parse]]
+   [mw-parser.simplify :refer [simplify]]))
 
 (deftest parse-flow-tests
   (testing "flow-grammar"
@@ -31,11 +32,13 @@
                       (:WITH "with")
                       (:FLOW-CONDITIONS
                        (:DETERMINER-CONDITION (:LEAST "least") (:SYMBOL "food")))))
-          actual (simplify-flow (parse-flow rule))]
+          actual (simplify (parse rule))]
+       
        (is (= actual expected) rule))
            (let [rule "flow 10% food from house having food more than 10 to each house within 2 with food less than 4"
              expected '(:FLOW-RULE 
-                        (:PERCENTAGE (:NUMBER "10") "%")
+                        (:FLOW "flow") 
+                        (:QUANTITY (:PERCENTAGE (:NUMBER "10") "%")) 
                         (:SYMBOL "food") 
                         (:FROM "from") 
                         (:SOURCE 
@@ -46,21 +49,21 @@
                          (:WITH "having") 
                          (:PROPERTY-CONDITION 
                           (:SYMBOL "food") 
-                          (:QUALIFIER (:COMPARATIVE-QUALIFIER (:MORE "more") (:THAN "than")))
+                          (:QUALIFIER 
+                           (:COMPARATIVE-QUALIFIER (:MORE "more") (:THAN "than")))
                           (:NUMBER "10"))) 
                         (:TO-HOW (:TO-EACH (:TO "to") (:EACH "each"))) 
                         (:DESTINATION 
-                         (:PROPERTY-CONDITION
+                         (:TARGET 
-                          (:SYMBOL "state")
-                          (:QUALIFIER (:EQUIVALENCE (:IS "is")))
-                          (:EXPRESSION (:VALUE [:SYMBOL "house"])))
-                         (:WITHIN "within")
-                         (:VALUE (:NUMBER "2"))
-                         (:WITH "with")
-                         (:FLOW-CONDITIONS
                           (:PROPERTY-CONDITION 
-                           (:SYMBOL "food")
+                           (:SYMBOL "state") (:QUALIFIER (:EQUIVALENCE (:IS "is"))) 
-                           (:QUALIFIER (:COMPARATIVE-QUALIFIER (:LESS "less") (:THAN "than")))
+                           (:EXPRESSION (:VALUE [:SYMBOL "house"]))) 
-                           (:NUMBER "4")))))
+                          (:RANGE (:WITHIN "within") (:NUMBER "2"))) 
-             actual (simplify-flow (parse-flow rule))]
+                         (:WITH "with") 
+                         (:PROPERTY-CONDITION 
+                          (:SYMBOL "food") 
+                          (:QUALIFIER 
+                           (:COMPARATIVE-QUALIFIER (:LESS "less") (:THAN "than"))) 
+                          (:NUMBER "4")))) 
+             actual (simplify (parse rule))]
          (is (= actual expected) rule))))

test/mw_parser/generate_test.clj

@@ -1,19 +1,17 @@
 (ns mw-parser.generate-test 
   (:require [clojure.test :refer [deftest is testing]]
-            [mw-parser.generate :refer [generate]]))
+            [mw-parser.generate :refer [generate]]
-
+            [mw-parser.declarative :refer [parse]]
-;; TODO: these tests are badly written and many (all?!?) of them were not 
+            [mw-parser.simplify :refer [simplify]]))
-;; actually firing. rewrite ALL to the pattern:
-;;
-;; (let [actual ...
-;;       expected ...]
-;;    (is (= actual expected)))
 
 (deftest expressions-tests
   (testing "Generating primitive expressions."
-    (is (= (generate '(:NUMERIC-EXPRESSION (:NUMBER "50"))) 50))
+    (let [actual (generate '(:NUMERIC-EXPRESSION (:NUMBER "50")))
-    (is (= (generate '(:NUMERIC-EXPRESSION (:SYMBOL "sealevel")))
+          expected 50] 
-        '(:sealevel cell)))))
+      (is (= actual expected)))
+    (let [actual (generate '(:NUMERIC-EXPRESSION (:SYMBOL "sealevel")))
+          expected '(:sealevel cell)]
+      (is (= actual expected)))))
 
 (deftest lhs-generators-tests
   (testing "Generating left-hand-side fragments of rule functions from appropriate fragments of parse trees"
@@ -85,3 +83,20 @@
           actual-meta (meta actual)]
       (is (= actual expected))
       (is (= actual-meta expected-meta)))))
+
+(deftest metadata-tests
+  (testing "Rules have correct metadata"
+    (let [expected :production
+        actual (:rule-type
+                (meta
+                (generate 
+                 (simplify 
+                  (parse "if state is house then state should be waste")))))]
+    (is (= actual expected)))
+    (let [expected :flow
+            actual (:rule-type
+                    (meta
+                     (generate
+                      (simplify
+                       (parse "flow 10% food from house to house within 2 with least food")))))]
+        (is (= actual expected)))))