From 93a0f3ea1de9f7df524e1a38757e668eafb4c97b Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Sat, 15 Jul 2023 07:27:20 +0100 Subject: [PATCH] Flow rule generation very nearly correct! Not all tests pass; additional conditions are not yet evaluated. --- src/mw_parser/core.clj | 4 +- src/mw_parser/flow.clj | 6 +- src/mw_parser/generate.clj | 118 ++++++++++++++++++++++++++----- src/mw_parser/simplify.clj | 16 ++++- src/mw_parser/utils.clj | 4 +- test/mw_parser/core_test.clj | 4 +- test/mw_parser/flow_test.clj | 65 +++++++++-------- test/mw_parser/generate_test.clj | 37 +++++++--- 8 files changed, 186 insertions(+), 68 deletions(-) diff --git a/src/mw_parser/core.clj b/src/mw_parser/core.clj index e287810..37150fc 100644 --- a/src/mw_parser/core.clj +++ b/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." diff --git a/src/mw_parser/flow.clj b/src/mw_parser/flow.clj index fcefaf4..93123d0 100644 --- a/src/mw_parser/flow.clj +++ b/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"])) diff --git a/src/mw_parser/generate.clj b/src/mw_parser/generate.clj index 3435d36..4c2f0c6 100644 --- a/src/mw_parser/generate.clj +++ b/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]] - [clojure.tools.trace :refer [deftrace]] - [mw-parser.utils :refer [assert-type TODO]] - [mw-parser.errors :as pe])) + (:require [mw-parser.errors :as pe] + [mw-parser.utils :refer [assert-type search-tree TODO]])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -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] - (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)))) + (vary-meta + (list 'fn ['cell 'world] + (list 'when (list 'and source (list 'pos? 'cell property)) + (list 'map + (list 'fn ['d] + {:source (list 'select-keys 'cell [:x :y]) + :destination (list 'select-keys 'd [:x :y]) + :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))] - (list 'fn ['cell 'world] - (list 'when (generate (:SOURCE clauses)))))) + (let [clauses (reduce #(assoc %1 (first %2) %2) {} (rest tree)) + source-accessor (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) diff --git a/src/mw_parser/simplify.clj b/src/mw_parser/simplify.clj index 643a23e..cab1071 100644 --- a/src/mw_parser/simplify.clj +++ b/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 diff --git a/src/mw_parser/utils.clj b/src/mw_parser/utils.clj index c846478..4c0a1bc 100644 --- a/src/mw_parser/utils.clj +++ b/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 diff --git a/test/mw_parser/core_test.clj b/test/mw_parser/core_test.clj index a01d10b..a64f52f 100644 --- a/test/mw_parser/core_test.clj +++ b/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") diff --git a/test/mw_parser/flow_test.clj b/test/mw_parser/flow_test.clj index 2167062..71b0c63 100644 --- a/test/mw_parser/flow_test.clj +++ b/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,36 +32,38 @@ (: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") "%") - (:SYMBOL "food") - (:FROM "from") - (:SOURCE - (:PROPERTY-CONDITION - (:SYMBOL "state") - (:QUALIFIER (:EQUIVALENCE (:IS "is"))) - (:EXPRESSION (:VALUE [:SYMBOL "house"]))) - (:WITH "having") - (:PROPERTY-CONDITION - (:SYMBOL "food") - (:QUALIFIER (:COMPARATIVE-QUALIFIER (:MORE "more") (:THAN "than"))) - (:NUMBER "10"))) - (:TO-HOW (:TO-EACH (:TO "to") (:EACH "each"))) - (:DESTINATION - (:PROPERTY-CONDITION - (:SYMBOL "state") - (:QUALIFIER (:EQUIVALENCE (:IS "is"))) - (:EXPRESSION (:VALUE [:SYMBOL "house"]))) - (:WITHIN "within") - (:VALUE (:NUMBER "2")) - (:WITH "with") - (:FLOW-CONDITIONS - (:PROPERTY-CONDITION - (:SYMBOL "food") - (:QUALIFIER (:COMPARATIVE-QUALIFIER (:LESS "less") (:THAN "than"))) - (:NUMBER "4"))))) - actual (simplify-flow (parse-flow rule))] + expected '(:FLOW-RULE + (:FLOW "flow") + (:QUANTITY (:PERCENTAGE (:NUMBER "10") "%")) + (:SYMBOL "food") + (:FROM "from") + (:SOURCE + (:PROPERTY-CONDITION + (:SYMBOL "state") + (:QUALIFIER (:EQUIVALENCE (:IS "is"))) + (:EXPRESSION (:VALUE [:SYMBOL "house"]))) + (:WITH "having") + (:PROPERTY-CONDITION + (:SYMBOL "food") + (:QUALIFIER + (:COMPARATIVE-QUALIFIER (:MORE "more") (:THAN "than"))) + (:NUMBER "10"))) + (:TO-HOW (:TO-EACH (:TO "to") (:EACH "each"))) + (:DESTINATION + (:TARGET + (:PROPERTY-CONDITION + (:SYMBOL "state") (:QUALIFIER (:EQUIVALENCE (:IS "is"))) + (:EXPRESSION (:VALUE [:SYMBOL "house"]))) + (:RANGE (:WITHIN "within") (:NUMBER "2"))) + (:WITH "with") + (:PROPERTY-CONDITION + (:SYMBOL "food") + (:QUALIFIER + (:COMPARATIVE-QUALIFIER (:LESS "less") (:THAN "than"))) + (:NUMBER "4")))) + actual (simplify (parse rule))] (is (= actual expected) rule)))) diff --git a/test/mw_parser/generate_test.clj b/test/mw_parser/generate_test.clj index 5220b98..07b18a8 100644 --- a/test/mw_parser/generate_test.clj +++ b/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]])) - -;; TODO: these tests are badly written and many (all?!?) of them were not -;; actually firing. rewrite ALL to the pattern: -;; -;; (let [actual ... -;; expected ...] -;; (is (= actual expected))) + [mw-parser.generate :refer [generate]] + [mw-parser.declarative :refer [parse]] + [mw-parser.simplify :refer [simplify]])) (deftest expressions-tests (testing "Generating primitive expressions." - (is (= (generate '(:NUMERIC-EXPRESSION (:NUMBER "50"))) 50)) - (is (= (generate '(:NUMERIC-EXPRESSION (:SYMBOL "sealevel"))) - '(:sealevel cell))))) + (let [actual (generate '(:NUMERIC-EXPRESSION (:NUMBER "50"))) + expected 50] + (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))))) \ No newline at end of file