From 2c567a65f1072dd6d0f95354b24f12a3fec29f6b Mon Sep 17 00:00:00 2001 From: simon Date: Thu, 3 Mar 2016 23:57:56 +0000 Subject: [PATCH 1/6] Added the new declarative parser. --- src/cljs/mw3/parser.cljs | 358 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 358 insertions(+) create mode 100644 src/cljs/mw3/parser.cljs diff --git a/src/cljs/mw3/parser.cljs b/src/cljs/mw3/parser.cljs new file mode 100644 index 0000000..40804c6 --- /dev/null +++ b/src/cljs/mw3/parser.cljs @@ -0,0 +1,358 @@ +(ns mw-parser.declarative + (:use mw-engine.utils + [clojure.string :only [split trim triml]]) + (:require [instaparse.core :as insta])) + + +;; 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") + + +(def grammar + ;; in order to simplify translation into other natural languages, all + ;; TOKENS within the parser should be unambiguous + "RULE := IF SPACE CONDITIONS SPACE THEN SPACE ACTIONS; + CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | PROPERTY-CONDITION | NEIGHBOURS-CONDITION ; + DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS; + CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS; + CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; + WITHIN-CONDITION := NEIGHBOURS-CONDITION SPACE WITHIN SPACE NUMERIC-EXPRESSION; + NEIGHBOURS-CONDITION := WITHIN-CONDITION | QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; + PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION; + EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; + SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; + DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE; + RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION; + NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION; + NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER; + COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN; + QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER; + QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER; + EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; + COMPARATIVE := MORE | LESS; + DISJUNCT-VALUE := VALUE | VALUE SPACE OR SPACE DISJUNCT-VALUE; + IF := 'if'; + THEN := 'then'; + THAN := 'than'; + OR := 'or'; + NOT := 'not'; + AND := 'and'; + SOME := 'some'; + NONE := 'no'; + ALL := 'all' + BETWEEN := 'between'; + WITHIN := 'within'; + IN := 'in'; + MORE := 'more'; + LESS := 'less' | 'fewer'; + OPERATOR := '+' | '-' | '*' | '/'; + NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors'; + PROPERTY := SYMBOL; + VALUE := SYMBOL | NUMBER; + EQUAL := 'equal to'; + IS := 'is' | 'are' | 'have' | 'has'; + NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+'; + SYMBOL := #'[a-z]+'; + ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS + ACTION := SIMPLE-ACTION | PROBABLE-ACTION; + PROBABLE-ACTION := VALUE SPACE 'chance in' SPACE VALUE SPACE SIMPLE-ACTION; + SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION + BECOMES := 'should be' + 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-condition + "Generate a property condition where the expression is a disjunct 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) + (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-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] + nil) +;; (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") +;; (conj 'do (map + +(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] + (generate-neighbours-condition tree (first (second tree)))) + ([tree quantifier-type] + (let [quantifier (second (second tree)) + pc (generate (nth tree 4))] + (case quantifier-type + :NUMBER (generate-neighbours-condition '= (read-string quantifier) pc 1) + :SOME (generate-neighbours-condition '> 0 pc 1) + :QUANTIFIER + (let [comparative (generate (simplify (second quantifier))) + value (simplify (nth quantifier 5))] + (generate-neighbours-condition comparative value pc 1))))) + ([comp1 quantity property-condition distance] + (list comp1 + (list 'count (list 'remove false (list 'map (list 'fn ['cell] property-condition) '(get-neighbours cell world distance)))) quantity)) + ([comp1 quantity property-condition] + (generate-neighbours-condition comp1 quantity property-condition 1))) + +;; (def s1 "if 3 neighbours have state equal to forest then state should be forest") +;; (def s2 "if some neighbours have state equal to forest then state should be forest") +;; (def s3 "if more than 3 neighbours have state equal to forest then state should be forest") +;; (def s4 "if fewer than 3 neighbours have state equal to forest then state should be forest") +;; (def s5 "if all neighbours have state equal to forest then state should be forest") +;; (def s6 "if more than 3 neighbours within 2 have state equal to forest then state should be forest") + +;; (nth (simplify (parse-rule s1)) 2) +;; (second (nth (simplify (parse-rule s1)) 2)) +;; (nth (simplify (parse-rule s2)) 2) +;; (map simplify (nth (simplify (parse-rule s2)) 2)) +;; ;; (second (nth (simplify (parse-rule s2)) 2)) +;; ;; (nth (simplify (parse-rule s3)) 2) +;; (second (nth (simplify (parse-rule s3)) 2)) +;; (map simplify (second (nth (simplify (parse-rule s3)) 2))) +;; ;; (nth (simplify (parse-rule s4)) 2) +;; ;; (second (nth (simplify (parse-rule s4)) 2)) +;; ;; (nth (simplify (parse-rule s5)) 2) +;; ;; (second (nth (simplify (parse-rule s5)) 2)) +;; ;; (nth (simplify (parse-rule s6)) 2) +;; ;; (second (nth (simplify (parse-rule s6)) 2)) + +;; ;; (generate (nth (nth (simplify (parse-rule s5)) 2) 4)) +;; ;; (generate (nth (simplify (parse-rule s2)) 2)) +;; ;; (generate (nth (simplify (parse-rule s1)) 2)) + + +;; (generate-neighbours-condition '= 3 '(= (:state cell) :forest) 1) +;; (generate-neighbours-condition (nth (simplify (parse-rule s3)) 2)) +;; (generate-neighbours-condition (nth (simplify (parse-rule s2)) 2)) +;; (generate-neighbours-condition (nth (simplify (parse-rule s1)) 2)) + + +(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) +;; :QUANTIFIER (simplify-second-of-two tree) + :NOT nil + :PROPERTY (simplify-second-of-two tree) + :SPACE nil + :THEN nil + ;; :QUALIFIER (simplify-qualifier tree) + :VALUE (simplify-second-of-two tree) + (remove nil? (map simplify tree))) + tree)) + +(def parse-rule + "Parse the argument, assumed to be a string in the correct syntax, and return a parse tree." + (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 %) " ") (first 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 (reduce (fn [map item](merge map {(first item)(rest item)})) {} parser-error) + text (first (: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)(first (: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 + "Compile this `rule`, assumed to be a string with appropriate syntax, into a function of two arguments, + a `cell` and a `world`, having the same semantics." + [rule] + (assert (string? rule)) + (let [tree (simplify (parse-rule rule))] + (if (rule? tree) (eval (generate tree)) + (throw-parse-exception tree)))) + + From 1d23b45dbd1571fc6cec2a8606620d2319e0c1dd Mon Sep 17 00:00:00 2001 From: simon Date: Fri, 4 Mar 2016 00:57:02 +0000 Subject: [PATCH 2/6] Added the parser, and using the cljs variant of the parser engine, but it's still not working properly. --- project.clj | 3 ++- src/cljs/mw3/parser.cljs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/project.clj b/project.clj index 98116b9..1fdfb7e 100644 --- a/project.clj +++ b/project.clj @@ -16,7 +16,8 @@ [secretary "1.2.3"] [environ "1.0.2"] [prismatic/dommy "1.1.0"] - [immoh/dommy.template "0.2.0"]] + [immoh/dommy.template "0.2.0"] + [com.lucasbradstreet/instaparse-cljs "1.4.1.0"]] :plugins [[lein-cljsbuild "1.1.1"] [lein-environ "1.0.1"]] diff --git a/src/cljs/mw3/parser.cljs b/src/cljs/mw3/parser.cljs index 40804c6..0609fe5 100644 --- a/src/cljs/mw3/parser.cljs +++ b/src/cljs/mw3/parser.cljs @@ -1,4 +1,4 @@ -(ns mw-parser.declarative +(ns ^:figwheel-always mw3.parser (:use mw-engine.utils [clojure.string :only [split trim triml]]) (:require [instaparse.core :as insta])) From 3bd1d7f29846cc6849ee7443e886cb4e21631d85 Mon Sep 17 00:00:00 2001 From: simon Date: Fri, 4 Mar 2016 08:25:25 +0000 Subject: [PATCH 3/6] WARNING! Does not currently compile, but I think that's probably not related to this code - I think it's junk in the working directory. --- src/cljs/mw3/core.cljs | 89 ++++-- src/cljs/mw3/parser.cljs | 634 +++++++++++++++++++-------------------- 2 files changed, 382 insertions(+), 341 deletions(-) diff --git a/src/cljs/mw3/core.cljs b/src/cljs/mw3/core.cljs index b13d955..6db81bc 100644 --- a/src/cljs/mw3/core.cljs +++ b/src/cljs/mw3/core.cljs @@ -78,41 +78,82 @@ ;; Rules page ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (deftemplate rule-editor - ;; "Constructs an editor for this `rule` with this `index` - [rule index] + ;; "Constructs an editor for this `rule` with this `index`, given this `total` + ;; number of rules. + [rule index total] [:div {:id (str "rule-editor-" index) :class "rule-editor"} [:input {:type "text" :id (str "rule-input-" index) :class "rule-input" :value rule}] [:div {:id (str "rule-controls-" index) :class "rule-controls"} - [:input {:type "button" :id (str "rule-ok-" index) :class "rule-ok" :value "ok"}] ;; ✔ - [:input {:type "button" :id (str "rule-up-" index) :class "rule-up" :value "up"}] ;; ↑ - [:input {:type "button" :id (str "rule-down-" index) :class "rule-down" :value "down"}] ;; ↓ - [:input {:type "button" :id (str "rule-delete-" index) :class "rule-delete" :value "delete"}]] ;; ✘ - [:pre {:id (str "rule-feedback-" index) :class "rule-feedback"}] - ]) + [:input {:type "button" + :id (str "rule-ok-" index) + :class "rule-ok" + :value "ok"}] ;; ✔ + [:input {:type "button" + :id (str "rule-up-" index) + :class "rule-up" + :value "up" + :disabled (= index 0)}] ;; ↑ + [:input {:type "button" + :id (str "rule-down-" index) + :class "rule-down" + :value "down" + :disabled (= index total)}] ;; ↓ + [:input {:type "button" + :id (str "rule-delete-" index) + :class "rule-delete" + :value "delete"}]] ;; ✘ + [:pre {:id (str "rule-feedback-" index) :class "rule-feedback"}]]) -;; (deftemplate rule-editors -;; ;; Constructs, as a `div`, a set of rule editors for the rules in the ruleset with -;; ;; this `ruleset-name`. -;; [ruleset-name] -;; [:div -;; (vec -;; (map -;; #(rule-editor % %) -;; (rulesets/rulesets ruleset-name) -;; (range)))]) +(defn rule-up-handler + "A handler to move the rule with index `n` one place up the list." + [n id] + (.log js/console (str id " pressed"))) + +(defn rule-down-handler + "A handler to move the rule with index `n` one place down the list." + [n id] + (.log js/console (str id " pressed"))) + +(defn rule-compile-handler + "A handler to compile the rule with index `n`." + [n id] + (.log js/console (str id " pressed"))) + +(defn rule-delete-handler + "A handler to delete the rule with index `n`." + [n id] + (.log js/console (str id " pressed"))) (defn load-ruleset - "Loads the ruleset with the specified `name` into a set of rule editors" + "Loads the ruleset with the specified `name` into a set of rule editors." [name] (let [rules-container (sel1 :#rules-container) - ruleset (rulesets/rulesets name)] + ruleset (rulesets/rulesets name) + total (count ruleset) + indexed-rules (map #(list %1 %2) ruleset (range))] (dommy/clear! rules-container) - (doseq [[rule index] (map #(list %1 %2) ruleset (range (count ruleset)))] - (dommy/append! rules-container (rule-editor rule index))))) + (doseq [[rule index] indexed-rules] + (dommy/append! rules-container (rule-editor rule index total))) + (doseq [[rule index] indexed-rules] + (let [ok-id (str "rule-ok-" index) + up-id (str "rule-up-" index) + down-id (str "rule-down-" index) + delete-id (str "rule-delete-" index) + ok-elt (sel1 ok-id) + up-elt (sel1 up-id) + down-elt (sel1 down-id) + delete-elt (sel1 delete-id)] + (if ok-elt + (dommy/listen! (sel1 ok-id) :click (fn [e] (rule-compile-handler e ok-id))) + (.log js/console (str "Could not find an element with id " ok-id))) + (if up-elt + (dommy/listen! (sel1 up-id) :click (fn [e] (rule-up-handler e up-id)))) + (if down-elt + (dommy/listen! (sel1 down-id) :click (fn [e] (rule-down-handler e down-id)))) + (if delete-elt + (dommy/listen! (sel1 delete-id) :click (fn [e] (rule-delete-handler e delete-id)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Set up the screen on loading diff --git a/src/cljs/mw3/parser.cljs b/src/cljs/mw3/parser.cljs index 0609fe5..1ec06cb 100644 --- a/src/cljs/mw3/parser.cljs +++ b/src/cljs/mw3/parser.cljs @@ -1,358 +1,358 @@ -(ns ^:figwheel-always mw3.parser - (:use mw-engine.utils - [clojure.string :only [split trim triml]]) - (:require [instaparse.core :as insta])) +;; (ns ^:figwheel-always mw3.parser +;; (:use mw-engine.utils +;; [clojure.string :only [split trim triml]]) +;; (:require [instaparse.core :as insta])) -;; 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") +;; ;; 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") -(def grammar - ;; in order to simplify translation into other natural languages, all - ;; TOKENS within the parser should be unambiguous - "RULE := IF SPACE CONDITIONS SPACE THEN SPACE ACTIONS; - CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | PROPERTY-CONDITION | NEIGHBOURS-CONDITION ; - DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS; - CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS; - CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; - WITHIN-CONDITION := NEIGHBOURS-CONDITION SPACE WITHIN SPACE NUMERIC-EXPRESSION; - NEIGHBOURS-CONDITION := WITHIN-CONDITION | QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; - PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION; - EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; - SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; - DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE; - RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION; - NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION; - NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER; - COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN; - QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER; - QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER; - EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; - COMPARATIVE := MORE | LESS; - DISJUNCT-VALUE := VALUE | VALUE SPACE OR SPACE DISJUNCT-VALUE; - IF := 'if'; - THEN := 'then'; - THAN := 'than'; - OR := 'or'; - NOT := 'not'; - AND := 'and'; - SOME := 'some'; - NONE := 'no'; - ALL := 'all' - BETWEEN := 'between'; - WITHIN := 'within'; - IN := 'in'; - MORE := 'more'; - LESS := 'less' | 'fewer'; - OPERATOR := '+' | '-' | '*' | '/'; - NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors'; - PROPERTY := SYMBOL; - VALUE := SYMBOL | NUMBER; - EQUAL := 'equal to'; - IS := 'is' | 'are' | 'have' | 'has'; - NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+'; - SYMBOL := #'[a-z]+'; - ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS - ACTION := SIMPLE-ACTION | PROBABLE-ACTION; - PROBABLE-ACTION := VALUE SPACE 'chance in' SPACE VALUE SPACE SIMPLE-ACTION; - SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION - BECOMES := 'should be' - SPACE := #' *'" - ) +;; (def grammar +;; ;; in order to simplify translation into other natural languages, all +;; ;; TOKENS within the parser should be unambiguous +;; "RULE := IF SPACE CONDITIONS SPACE THEN SPACE ACTIONS; +;; CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | PROPERTY-CONDITION | NEIGHBOURS-CONDITION ; +;; DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS; +;; CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS; +;; CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; +;; WITHIN-CONDITION := NEIGHBOURS-CONDITION SPACE WITHIN SPACE NUMERIC-EXPRESSION; +;; NEIGHBOURS-CONDITION := WITHIN-CONDITION | QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; +;; PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION; +;; EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; +;; SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; +;; DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE; +;; RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION; +;; NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION; +;; NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER; +;; COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN; +;; QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER; +;; QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER; +;; EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; +;; COMPARATIVE := MORE | LESS; +;; DISJUNCT-VALUE := VALUE | VALUE SPACE OR SPACE DISJUNCT-VALUE; +;; IF := 'if'; +;; THEN := 'then'; +;; THAN := 'than'; +;; OR := 'or'; +;; NOT := 'not'; +;; AND := 'and'; +;; SOME := 'some'; +;; NONE := 'no'; +;; ALL := 'all' +;; BETWEEN := 'between'; +;; WITHIN := 'within'; +;; IN := 'in'; +;; MORE := 'more'; +;; LESS := 'less' | 'fewer'; +;; OPERATOR := '+' | '-' | '*' | '/'; +;; NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors'; +;; PROPERTY := SYMBOL; +;; VALUE := SYMBOL | NUMBER; +;; EQUAL := 'equal to'; +;; IS := 'is' | 'are' | 'have' | 'has'; +;; NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+'; +;; SYMBOL := #'[a-z]+'; +;; ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS +;; ACTION := SIMPLE-ACTION | PROBABLE-ACTION; +;; PROBABLE-ACTION := VALUE SPACE 'chance in' SPACE VALUE SPACE SIMPLE-ACTION; +;; SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION +;; BECOMES := 'should be' +;; SPACE := #' *'" +;; ) -(defn TODO - "Marker to indicate I'm not yet finished!" - [message] - message) +;; (defn TODO +;; "Marker to indicate I'm not yet finished!" +;; [message] +;; message) -(declare generate simplify) +;; (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 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 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-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-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-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-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-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-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-condition - "Generate a property condition where the expression is a disjunct 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-disjunct-condition +;; "Generate a property condition where the expression is a disjunct 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) - (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-condition tree property qualifier expression) - :RANGE-EXPRESSION (generate-ranged-property-condition tree property expression) - (list qualifier (list property 'cell) expression))))) +;; (defn generate-property-condition +;; ([tree] +;; (assert-type tree :PROPERTY-CONDITION) +;; (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-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-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] - nil) -;; (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") -;; (conj 'do (map +;; (defn generate-multiple-actions +;; [tree] +;; nil) +;; ;; (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") +;; ;; (conj 'do (map -(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-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-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] - (generate-neighbours-condition tree (first (second tree)))) - ([tree quantifier-type] - (let [quantifier (second (second tree)) - pc (generate (nth tree 4))] - (case quantifier-type - :NUMBER (generate-neighbours-condition '= (read-string quantifier) pc 1) - :SOME (generate-neighbours-condition '> 0 pc 1) - :QUANTIFIER - (let [comparative (generate (simplify (second quantifier))) - value (simplify (nth quantifier 5))] - (generate-neighbours-condition comparative value pc 1))))) - ([comp1 quantity property-condition distance] - (list comp1 - (list 'count (list 'remove false (list 'map (list 'fn ['cell] property-condition) '(get-neighbours cell world distance)))) quantity)) - ([comp1 quantity property-condition] - (generate-neighbours-condition comp1 quantity property-condition 1))) +;; (defn generate-neighbours-condition +;; "Generate code for a condition which refers to neighbours." +;; ([tree] +;; (generate-neighbours-condition tree (first (second tree)))) +;; ([tree quantifier-type] +;; (let [quantifier (second (second tree)) +;; pc (generate (nth tree 4))] +;; (case quantifier-type +;; :NUMBER (generate-neighbours-condition '= (read-string quantifier) pc 1) +;; :SOME (generate-neighbours-condition '> 0 pc 1) +;; :QUANTIFIER +;; (let [comparative (generate (simplify (second quantifier))) +;; value (simplify (nth quantifier 5))] +;; (generate-neighbours-condition comparative value pc 1))))) +;; ([comp1 quantity property-condition distance] +;; (list comp1 +;; (list 'count (list 'remove false (list 'map (list 'fn ['cell] property-condition) '(get-neighbours cell world distance)))) quantity)) +;; ([comp1 quantity property-condition] +;; (generate-neighbours-condition comp1 quantity property-condition 1))) -;; (def s1 "if 3 neighbours have state equal to forest then state should be forest") -;; (def s2 "if some neighbours have state equal to forest then state should be forest") -;; (def s3 "if more than 3 neighbours have state equal to forest then state should be forest") -;; (def s4 "if fewer than 3 neighbours have state equal to forest then state should be forest") -;; (def s5 "if all neighbours have state equal to forest then state should be forest") -;; (def s6 "if more than 3 neighbours within 2 have state equal to forest then state should be forest") +;; ;; (def s1 "if 3 neighbours have state equal to forest then state should be forest") +;; ;; (def s2 "if some neighbours have state equal to forest then state should be forest") +;; ;; (def s3 "if more than 3 neighbours have state equal to forest then state should be forest") +;; ;; (def s4 "if fewer than 3 neighbours have state equal to forest then state should be forest") +;; ;; (def s5 "if all neighbours have state equal to forest then state should be forest") +;; ;; (def s6 "if more than 3 neighbours within 2 have state equal to forest then state should be forest") -;; (nth (simplify (parse-rule s1)) 2) -;; (second (nth (simplify (parse-rule s1)) 2)) -;; (nth (simplify (parse-rule s2)) 2) -;; (map simplify (nth (simplify (parse-rule s2)) 2)) -;; ;; (second (nth (simplify (parse-rule s2)) 2)) -;; ;; (nth (simplify (parse-rule s3)) 2) -;; (second (nth (simplify (parse-rule s3)) 2)) -;; (map simplify (second (nth (simplify (parse-rule s3)) 2))) -;; ;; (nth (simplify (parse-rule s4)) 2) -;; ;; (second (nth (simplify (parse-rule s4)) 2)) -;; ;; (nth (simplify (parse-rule s5)) 2) -;; ;; (second (nth (simplify (parse-rule s5)) 2)) -;; ;; (nth (simplify (parse-rule s6)) 2) -;; ;; (second (nth (simplify (parse-rule s6)) 2)) +;; ;; (nth (simplify (parse-rule s1)) 2) +;; ;; (second (nth (simplify (parse-rule s1)) 2)) +;; ;; (nth (simplify (parse-rule s2)) 2) +;; ;; (map simplify (nth (simplify (parse-rule s2)) 2)) +;; ;; ;; (second (nth (simplify (parse-rule s2)) 2)) +;; ;; ;; (nth (simplify (parse-rule s3)) 2) +;; ;; (second (nth (simplify (parse-rule s3)) 2)) +;; ;; (map simplify (second (nth (simplify (parse-rule s3)) 2))) +;; ;; ;; (nth (simplify (parse-rule s4)) 2) +;; ;; ;; (second (nth (simplify (parse-rule s4)) 2)) +;; ;; ;; (nth (simplify (parse-rule s5)) 2) +;; ;; ;; (second (nth (simplify (parse-rule s5)) 2)) +;; ;; ;; (nth (simplify (parse-rule s6)) 2) +;; ;; ;; (second (nth (simplify (parse-rule s6)) 2)) -;; ;; (generate (nth (nth (simplify (parse-rule s5)) 2) 4)) -;; ;; (generate (nth (simplify (parse-rule s2)) 2)) -;; ;; (generate (nth (simplify (parse-rule s1)) 2)) +;; ;; ;; (generate (nth (nth (simplify (parse-rule s5)) 2) 4)) +;; ;; ;; (generate (nth (simplify (parse-rule s2)) 2)) +;; ;; ;; (generate (nth (simplify (parse-rule s1)) 2)) -;; (generate-neighbours-condition '= 3 '(= (:state cell) :forest) 1) -;; (generate-neighbours-condition (nth (simplify (parse-rule s3)) 2)) -;; (generate-neighbours-condition (nth (simplify (parse-rule s2)) 2)) -;; (generate-neighbours-condition (nth (simplify (parse-rule s1)) 2)) +;; ;; (generate-neighbours-condition '= 3 '(= (:state cell) :forest) 1) +;; ;; (generate-neighbours-condition (nth (simplify (parse-rule s3)) 2)) +;; ;; (generate-neighbours-condition (nth (simplify (parse-rule s2)) 2)) +;; ;; (generate-neighbours-condition (nth (simplify (parse-rule s1)) 2)) -(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 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-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-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 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) -;; :QUANTIFIER (simplify-second-of-two tree) - :NOT nil - :PROPERTY (simplify-second-of-two tree) - :SPACE nil - :THEN nil - ;; :QUALIFIER (simplify-qualifier tree) - :VALUE (simplify-second-of-two tree) - (remove nil? (map simplify tree))) - 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 (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) +;; ;; :QUANTIFIER (simplify-second-of-two tree) +;; :NOT nil +;; :PROPERTY (simplify-second-of-two tree) +;; :SPACE nil +;; :THEN nil +;; ;; :QUALIFIER (simplify-qualifier tree) +;; :VALUE (simplify-second-of-two tree) +;; (remove nil? (map simplify tree))) +;; tree)) -(def parse-rule - "Parse the argument, assumed to be a string in the correct syntax, and return a parse tree." - (insta/parser grammar)) +;; (def parse-rule +;; "Parse the argument, assumed to be a string in the correct syntax, and return a parse tree." +;; (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 %) " ") (first reason))) ")")) +;; (defn explain-parse-error-reason +;; "Attempt to explain the reason for the parse error." +;; [reason] +;; (str "Expecting one of (" (apply str (map #(str (:expecting %) " ") (first 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 (reduce (fn [map item](merge map {(first item)(rest item)})) {} parser-error) - text (first (: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)(first (: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 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 (reduce (fn [map item](merge map {(first item)(rest item)})) {} parser-error) +;; text (first (: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)(first (: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 - "Compile this `rule`, assumed to be a string with appropriate syntax, into a function of two arguments, - a `cell` and a `world`, having the same semantics." - [rule] - (assert (string? rule)) - (let [tree (simplify (parse-rule rule))] - (if (rule? tree) (eval (generate tree)) - (throw-parse-exception tree)))) +;; (defn compile-rule +;; "Compile this `rule`, assumed to be a string with appropriate syntax, into a function of two arguments, +;; a `cell` and a `world`, having the same semantics." +;; [rule] +;; (assert (string? rule)) +;; (let [tree (simplify (parse-rule rule))] +;; (if (rule? tree) (eval (generate tree)) +;; (throw-parse-exception tree)))) From 0716b517cb4029a52b7c3dc4fae2319d79c83085 Mon Sep 17 00:00:00 2001 From: simon Date: Thu, 10 Mar 2016 08:31:04 +0000 Subject: [PATCH 4/6] This again doesn't compile, with the same error - can't take nth of symbol - as previously, and again I don't know why. --- project.clj | 3 +- src/cljs/mw3/core.cljs | 1 + src/cljs/mw3/parser.cljc | 356 +++++++++++++++++++++++++++++++++++++++ src/cljs/mw3/utils.cljc | 274 ++++++++++++++++++++++++++++++ 4 files changed, 633 insertions(+), 1 deletion(-) create mode 100644 src/cljs/mw3/parser.cljc create mode 100644 src/cljs/mw3/utils.cljc diff --git a/project.clj b/project.clj index 98116b9..1fdfb7e 100644 --- a/project.clj +++ b/project.clj @@ -16,7 +16,8 @@ [secretary "1.2.3"] [environ "1.0.2"] [prismatic/dommy "1.1.0"] - [immoh/dommy.template "0.2.0"]] + [immoh/dommy.template "0.2.0"] + [com.lucasbradstreet/instaparse-cljs "1.4.1.0"]] :plugins [[lein-cljsbuild "1.1.1"] [lein-environ "1.0.1"]] diff --git a/src/cljs/mw3/core.cljs b/src/cljs/mw3/core.cljs index 33de0c2..eb2dc9b 100644 --- a/src/cljs/mw3/core.cljs +++ b/src/cljs/mw3/core.cljs @@ -1,4 +1,5 @@ (ns ^:figwheel-always mw3.core + (:use mw3.utils) (:use-macros [dommy.template :only [node deftemplate]]) (:require-macros [cljs.core.async.macros :refer [go]]) (:require diff --git a/src/cljs/mw3/parser.cljc b/src/cljs/mw3/parser.cljc new file mode 100644 index 0000000..7567b9a --- /dev/null +++ b/src/cljs/mw3/parser.cljc @@ -0,0 +1,356 @@ +(ns ^:figwheel-always mw3.core + (:use mw3.utils + [clojure.string :only [split trim triml]]) + (:require [instaparse.core :as insta])) + +;; 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 +(defn bad-parse-error + [rule-text cursor reason] + (str "I did not understand:\n'" rule-text "'\n" cursor "\n" reason)) + +(def grammar + ;; in order to simplify translation into other natural languages, all + ;; TOKENS within the parser should be unambiguous + "RULE := IF SPACE CONDITIONS SPACE THEN SPACE ACTIONS; + CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | PROPERTY-CONDITION | NEIGHBOURS-CONDITION ; + DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS; + CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS; + CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; + WITHIN-CONDITION := NEIGHBOURS-CONDITION SPACE WITHIN SPACE NUMERIC-EXPRESSION; + NEIGHBOURS-CONDITION := WITHIN-CONDITION | QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; + PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION; + EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; + SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; + DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE; + RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION; + NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION; + NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER; + COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN; + QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER; + QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER; + EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; + COMPARATIVE := MORE | LESS; + DISJUNCT-VALUE := VALUE | VALUE SPACE OR SPACE DISJUNCT-VALUE; + IF := 'if'; + THEN := 'then'; + THAN := 'than'; + OR := 'or'; + NOT := 'not'; + AND := 'and'; + SOME := 'some'; + NONE := 'no'; + ALL := 'all' + BETWEEN := 'between'; + WITHIN := 'within'; + IN := 'in'; + MORE := 'more'; + LESS := 'less' | 'fewer'; + OPERATOR := '+' | '-' | '*' | '/'; + NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors'; + PROPERTY := SYMBOL; + VALUE := SYMBOL | NUMBER; + EQUAL := 'equal to'; + IS := 'is' | 'are' | 'have' | 'has'; + NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+'; + SYMBOL := #'[a-z]+'; + ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS + ACTION := SIMPLE-ACTION | PROBABLE-ACTION; + PROBABLE-ACTION := VALUE SPACE 'chance in' SPACE VALUE SPACE SIMPLE-ACTION; + SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION + BECOMES := 'should be' + 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 (error (str "Expected a " type " fragment"))))) + +(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 + "Generate a property condition where the expression is a disjunct expression" + [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-condition-4 + "Generate a property condition where the expression is a disjunct 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) + (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-condition-4 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 (error reserved-properties-error)) + (list 'merge 'cell {property expression})))) + +(defn generate-multiple-actions + [tree] + nil) +;; (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") +;; (conj 'do (map + +(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] + (generate-neighbours-condition tree (first (second tree)))) + ([tree quantifier-type] + (let [quantifier (second (second tree)) + pc (generate (nth tree 4))] + (case quantifier-type + :NUMBER (generate-neighbours-condition '= (read-string quantifier) pc 1) + :SOME (generate-neighbours-condition '> 0 pc 1) + :QUANTIFIER + (let [comparative (generate (simplify (second quantifier))) + value (simplify (nth quantifier 5))] + (generate-neighbours-condition comparative value pc 1))))) + ([comp1 quantity property-condition distance] + (list comp1 + (list 'count (list 'remove false (list 'map (list 'fn ['cell] property-condition) '(get-neighbours cell world distance)))) quantity)) + ([comp1 quantity property-condition] + (generate-neighbours-condition comp1 quantity property-condition 1))) + +;; (def s1 "if 3 neighbours have state equal to forest then state should be forest") +;; (def s2 "if some neighbours have state equal to forest then state should be forest") +;; (def s3 "if more than 3 neighbours have state equal to forest then state should be forest") +;; (def s4 "if fewer than 3 neighbours have state equal to forest then state should be forest") +;; (def s5 "if all neighbours have state equal to forest then state should be forest") +;; (def s6 "if more than 3 neighbours within 2 have state equal to forest then state should be forest") + +;; (nth (simplify (parse-rule s1)) 2) +;; (second (nth (simplify (parse-rule s1)) 2)) +;; (nth (simplify (parse-rule s2)) 2) +;; (map simplify (nth (simplify (parse-rule s2)) 2)) +;; ;; (second (nth (simplify (parse-rule s2)) 2)) +;; ;; (nth (simplify (parse-rule s3)) 2) +;; (second (nth (simplify (parse-rule s3)) 2)) +;; (map simplify (second (nth (simplify (parse-rule s3)) 2))) +;; ;; (nth (simplify (parse-rule s4)) 2) +;; ;; (second (nth (simplify (parse-rule s4)) 2)) +;; ;; (nth (simplify (parse-rule s5)) 2) +;; ;; (second (nth (simplify (parse-rule s5)) 2)) +;; ;; (nth (simplify (parse-rule s6)) 2) +;; ;; (second (nth (simplify (parse-rule s6)) 2)) + +;; ;; (generate (nth (nth (simplify (parse-rule s5)) 2) 4)) +;; ;; (generate (nth (simplify (parse-rule s2)) 2)) +;; ;; (generate (nth (simplify (parse-rule s1)) 2)) + + +;; (generate-neighbours-condition '= 3 '(= (:state cell) :forest) 1) +;; (generate-neighbours-condition (nth (simplify (parse-rule s3)) 2)) +;; (generate-neighbours-condition (nth (simplify (parse-rule s2)) 2)) +;; (generate-neighbours-condition (nth (simplify (parse-rule s1)) 2)) + + +(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) +;; :QUANTIFIER (simplify-second-of-two tree) + :NOT nil + :PROPERTY (simplify-second-of-two tree) + :SPACE nil + :THEN nil + ;; :QUALIFIER (simplify-qualifier tree) + :VALUE (simplify-second-of-two tree) + (remove nil? (map simplify tree))) + tree)) + +(def parse-rule + "Parse the argument, assumed to be a string in the correct syntax, and return a parse tree." + (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 %) " ") (first 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 (reduce (fn [map item](merge map {(first item)(rest item)})) {} parser-error) + text (first (: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)(first (:column error-map)) 0) + ;; create a cursor to point to that column + cursor (apply str (reverse (conj (repeat column " ") "^"))) + message (bad-parse-error text cursor reason) + ] + (throw (error message)))) + +(defn compile-rule + "Compile this `rule`, assumed to be a string with appropriate syntax, into a function of two arguments, + a `cell` and a `world`, having the same semantics." + [rule] + (assert (string? rule)) + (let [tree (simplify (parse-rule rule))] + (if (rule? tree) (eval (generate tree)) + (throw-parse-exception tree)))) diff --git a/src/cljs/mw3/utils.cljc b/src/cljs/mw3/utils.cljc new file mode 100644 index 0000000..16a8e12 --- /dev/null +++ b/src/cljs/mw3/utils.cljc @@ -0,0 +1,274 @@ +(ns ^:figwheel-always mw3.utils) + +(defn error + [message] + #?(:cljs (js/Error. message) + :clj (Exception. message))) + +(defn nth + "I'm getting a compilation error saying `nth` isn't defined; so I'm defining it." + [collection index] + {:pre [(and (coll? collection) (integer? index) (or (zero? index) (pos? index)))]} + (cond + (empty? collection) nil + (zero? index) (first collection) + :true (nth (rest collection) (dec index)))) + +(defn abs + "Surprisingly, Clojure doesn't seem to have an abs function, or else I've + missed it. So here's one of my own. Maps natural numbers onto themselves, + and negative integers onto natural numbers. Also maps negative real numbers + onto positive real numbers. + + * `n` a number, on the set of real numbers." + [n] + (if (neg? n) (- 0 n) n)) + +(defn member? + "True if elt is a member of col." + [elt col] (some #(= elt %) col)) + +(defn get-int-or-zero + "Return the value of this `property` from this `map` if it is a integer; + otherwise return zero." + [map property] + (let [value (map property)] + (if (integer? value) value 0))) + +(defn init-generation + "Return a cell like this `cell`, but having a value for :generation, zero if + the cell passed had no integer value for generation, otherwise the value + taken from the cell passed. The `world` argument is present only for + consistency with the rule engine and is ignored." + [world cell] + (merge cell {:generation (get-int-or-zero cell :generation)})) + + +(defn in-bounds + "True if x, y are in bounds for this world (i.e., there is a cell at x, y) + else false. + + * `world` a world as defined above; + * `x` a number which may or may not be a valid x coordinate within that world; + * `y` a number which may or may not be a valid y coordinate within that world." + [world x y] + (and (>= x 0)(>= y 0)(< y (count world))(< x (count (first world))))) + +#?(:cljs + ;; conditional compilation: JavaScript doesn't do parallel mapping. + (defn map-world + "Wholly non-parallel map world implementation" + ([world function] + (map-world world function nil)) + ([world function additional-args] + (into [] + (map (fn [row] + (into [] (map + #(apply function + (cons world (cons % additional-args))) + row))) + world)))) + :clj + (defn map-world + "Apply this `function` to each cell in this `world` to produce a new world. + the arguments to the function will be the world, the cell, and any + `additional-args` supplied. Note that we parallel map over rows but + just map over cells within a row. That's because it isn't worth starting + a new thread for each cell, but there may be efficiency gains in + running rows in parallel." + ([world function] + (map-world world function nil)) + ([world function additional-args] + (into [] + (pmap (fn [row] + (into [] (map + #(apply function + (cons world (cons % additional-args))) + row))) + world))))) + +(defn get-cell + "Return the cell a x, y in this world, if any. + + * `world` a world as defined above; + * `x` a number which may or may not be a valid x coordinate within that world; + * `y` a number which may or may not be a valid y coordinate within that world." + [world x y] + (cond (in-bounds world x y) + (nth (nth world y) x))) + +(defn get-int + "Get the value of a property expected to be an integer from a map; if not present (or not an integer) return 0. + + * `map` a map; + * `key` a symbol or keyword, presumed to be a key into the `map`." + [map key] + (cond (map? map) + (let [v (map key)] + (cond (and v (integer? v)) v + true 0)) + true (throw (error "No map passed?")))) + +(defn population + "Return the population of this species in this cell. Currently a synonym for + `get-int`, but may not always be (depending whether species are later + implemented as actors) + + * `cell` a map; + * `species` a keyword representing a species which may populate that cell." + [cell species] + (get-int cell species)) + +(defn cartesian-product [x-seq y-seq] + (map (fn [n] (map #(list n %)) x-seq) y-seq)) + ;; not right, but nearly + +(def memo-get-neighbours + "Memoised get neighbours is more efficient when running deeply recursive + algorithms on the same world. But it's less efficient when running the + engine in its normal iterative style, because then we will rarely call + get naighbours on the same cell of the same world twice." + (memoize + (fn [world x y depth] + (remove nil? + (map #(get-cell world (first %) (first (rest %))) + (remove #(= % (list x y)) + (cartesian-product + (range (- x depth) (+ x depth 1)) + (range (- y depth) (+ y depth 1))))))))) + +(defn get-neighbours + "Get the neighbours to distance depth of a cell in this world. + + Several overloads: + * `world` a world, as described in world.clj; + * `cell` a cell within that world + Gets immediate neighbours of the specified cell. + + * `world` a world, as described in world.clj; + * `cell` a cell within that world + * `depth` an integer representing the depth to search from the + `cell` + Gets neighbours within the specified distance of the cell. + + * `world` a world, as described in world.clj; + * `x` an integer representing an x coordinate in that world; + * `y` an integer representing an y coordinate in that world; + * `depth` an integer representing the distance from [x,y] that + should be searched + Gets the neighbours within the specified distance of the cell at + coordinates [x,y] in this world." + ([world x y depth] + (remove nil? + (map #(get-cell world (first %) (first (rest %))) + (remove #(= % (list x y)) + (cartesian-product + (range (- x depth) (+ x depth 1)) + (range (- y depth) (+ y depth 1))))))) + ([world cell depth] + (memo-get-neighbours world (:x cell) (:y cell) depth)) + ([world cell] + (get-neighbours world cell 1))) + +;; (defn get-neighbours-with-property-value +;; "Get the neighbours to distance depth of the cell at x, y in this world which +;; have this value for this property. + +;; * `world` a world, as described in `world.clj`; +;; * `cell` a cell within that world; +;; * `depth` an integer representing the distance from [x,y] that +;; should be searched (optional); +;; * `property` a keyword representing a property of the neighbours; +;; * `value` a value of that property (or, possibly, the name of another); +;; * `op` a comparator function to use in place of `=` (optional). + +;; It gets messy." +;; ([world x y depth property value op] +;; (filter +;; #(eval +;; (list op +;; (or (get % property) (get-int % property)) +;; value)) +;; (get-neighbours world x y depth))) +;; ([world x y depth property value] +;; (get-neighbours-with-property-value world x y depth property value =)) +;; ([world cell depth property value] +;; (get-neighbours-with-property-value world (:x cell) (:y cell) depth +;; property value)) +;; ([world cell property value] +;; (get-neighbours-with-property-value world cell 1 +;; property value))) + +(defn get-neighbours-with-state + "Get the neighbours to distance depth of the cell at x, y in this world which + have this state. + + * `world` a world, as described in `world.clj`; + * `cell` a cell within that world; + * `depth` an integer representing the distance from [x,y] that + should be searched; + * `state` a keyword representing a state in the world." + ([world x y depth state] + (filter #(= (:state %) state) (get-neighbours world x y depth))) + ([world cell depth state] + (get-neighbours-with-state world (:x cell) (:y cell) depth state)) + ([world cell state] + (get-neighbours-with-state world cell 1 state))) + +(defn get-least-cell + "Return the cell from among these `cells` which has the lowest numeric value + for this `property`; if the property is absent or not a number, use this + `default`" + ([cells property default] + (cond + (empty? cells) nil + true (let [downstream (get-least-cell (rest cells) property default)] + (cond (< + (or (property (first cells)) default) + (or (property downstream) default)) (first cells) + true downstream)))) + ([cells property] + (get-least-cell cells property #?(:cljs 900719925474099 + :clj (Integer/MAX_VALUE))))) + + +(defn- set-cell-property + "If this `cell`s x and y properties are equal to these `x` and `y` values, + return a cell like this cell but with the value of this `property` set to + this `value`. Otherwise, just return this `cell`." + [cell x y property value] + (cond + (and (= x (:x cell)) (= y (:y cell))) + (merge cell {property value :rule "Set by user"}) + true + cell)) + +(defn set-property + "Return a world like this `world` but with the value of exactly one `property` + of one `cell` changed to this `value`" + ([world cell property value] + (set-property world (:x cell) (:y cell) property value)) + ([world x y property value] + (apply + vector ;; we want a vector of vectors, not a list of lists, for efficiency + (map + (fn [row] + (apply + vector + (map #(set-cell-property % x y property value) + row))) + world)))) + +(defn merge-cell + "Return a world like this `world`, but merge the values from this `cell` with + those from the cell in the world with the same co-ordinates" + [world cell] + (if (in-bounds world (:x cell) (:y cell)) + (map-world world + #(if + (and + (= (:x cell)(:x %2)) + (= (:y cell)(:y %2))) + (merge %2 cell) + %2)) + world)) From 7c7657c309bae79b014a1f6ec80ada5d661b7b21 Mon Sep 17 00:00:00 2001 From: simon Date: Thu, 10 Mar 2016 21:21:20 +0000 Subject: [PATCH 5/6] This commit contains most of what's been written so far, and it all compiles. However, the parser does not work (because it depends on eval), and also the parser can't currently be linked into core and I don't know why not. Still, significant progress. --- project.clj | 3 +- src/cljs/mw3/core.cljs | 3 +- src/cljs/mw3/parser.cljc | 329 +++++++++++++++++++++++++++++++++++++++ src/cljs/mw3/utils.cljc | 255 ++++++++++++++++++++++++++++++ 4 files changed, 588 insertions(+), 2 deletions(-) create mode 100644 src/cljs/mw3/parser.cljc create mode 100644 src/cljs/mw3/utils.cljc diff --git a/project.clj b/project.clj index 98116b9..1fdfb7e 100644 --- a/project.clj +++ b/project.clj @@ -16,7 +16,8 @@ [secretary "1.2.3"] [environ "1.0.2"] [prismatic/dommy "1.1.0"] - [immoh/dommy.template "0.2.0"]] + [immoh/dommy.template "0.2.0"] + [com.lucasbradstreet/instaparse-cljs "1.4.1.0"]] :plugins [[lein-cljsbuild "1.1.1"] [lein-environ "1.0.1"]] diff --git a/src/cljs/mw3/core.cljs b/src/cljs/mw3/core.cljs index 33de0c2..54a3722 100644 --- a/src/cljs/mw3/core.cljs +++ b/src/cljs/mw3/core.cljs @@ -4,7 +4,8 @@ (:require [mw3.rulesets :as rulesets] [dommy.core :as dommy :refer-macros [sel sel1]] - [dommy.template :as temp])) + [dommy.template :as temp] + )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/cljs/mw3/parser.cljc b/src/cljs/mw3/parser.cljc new file mode 100644 index 0000000..90b7719 --- /dev/null +++ b/src/cljs/mw3/parser.cljc @@ -0,0 +1,329 @@ +(ns ^:figwheel-always mw3.core + (:use [mw3.utils :only [error member?]] + [clojure.string :only [split trim triml]] + #?(:cljs + [cljs.reader :only [read-string]])) + (:require [instaparse.core :as insta]) + ) + +;; 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 +(defn bad-parse-error + [rule-text cursor reason] + (str "I did not understand:\n'" rule-text "'\n" cursor "\n" reason)) + +(def grammar + ;; in order to simplify translation into other natural languages, all + ;; TOKENS within the parser should be unambiguous + "RULE := IF SPACE CONDITIONS SPACE THEN SPACE ACTIONS; + CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | PROPERTY-CONDITION | NEIGHBOURS-CONDITION ; + DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS; + CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS; + CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; + WITHIN-CONDITION := NEIGHBOURS-CONDITION SPACE WITHIN SPACE NUMERIC-EXPRESSION; + NEIGHBOURS-CONDITION := WITHIN-CONDITION | QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; + PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION; + EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; + SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; + DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE; + RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION; + NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION; + NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER; + COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN; + QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER; + QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER; + EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; + COMPARATIVE := MORE | LESS; + DISJUNCT-VALUE := VALUE | VALUE SPACE OR SPACE DISJUNCT-VALUE; + IF := 'if'; + THEN := 'then'; + THAN := 'than'; + OR := 'or'; + NOT := 'not'; + AND := 'and'; + SOME := 'some'; + NONE := 'no'; + ALL := 'all' + BETWEEN := 'between'; + WITHIN := 'within'; + IN := 'in'; + MORE := 'more'; + LESS := 'less' | 'fewer'; + OPERATOR := '+' | '-' | '*' | '/'; + NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors'; + PROPERTY := SYMBOL; + VALUE := SYMBOL | NUMBER; + EQUAL := 'equal to'; + IS := 'is' | 'are' | 'have' | 'has'; + NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+'; + SYMBOL := #'[a-z]+'; + ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS + ACTION := SIMPLE-ACTION | PROBABLE-ACTION; + PROBABLE-ACTION := VALUE SPACE 'chance in' SPACE VALUE SPACE SIMPLE-ACTION; + SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION + BECOMES := 'should be' + 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 (error (str "Expected a " type " fragment"))))) + +(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 + "Generate a property condition where the expression is a disjunct expression" + [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-condition-4 + "Generate a property condition where the expression is a disjunct 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) + (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-condition-4 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 (error reserved-properties-error)) + (list 'merge 'cell {property expression})))) + +(defn generate-multiple-actions + [tree] + nil) +;; (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") +;; (conj 'do (map + +(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] + (generate-neighbours-condition tree (first (second tree)))) + ([tree quantifier-type] + (let [quantifier (second (second tree)) + pc (generate (nth tree 4))] + (case quantifier-type + :NUMBER (generate-neighbours-condition '= (read-string quantifier) pc 1) + :SOME (generate-neighbours-condition '> 0 pc 1) + :QUANTIFIER + (let [comparative (generate (simplify (second quantifier))) + value (simplify (nth quantifier 5))] + (generate-neighbours-condition comparative value pc 1))))) + ([comp1 quantity property-condition distance] + (list comp1 + (list 'count (list 'remove false (list 'map (list 'fn ['cell] property-condition) '(get-neighbours cell world 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) +;; :QUANTIFIER (simplify-second-of-two tree) + :NOT nil + :PROPERTY (simplify-second-of-two tree) + :SPACE nil + :THEN nil + ;; :QUALIFIER (simplify-qualifier tree) + :VALUE (simplify-second-of-two tree) + (remove nil? (map simplify tree))) + tree)) + +(def parse-rule + "Parse the argument, assumed to be a string in the correct syntax, and return a parse tree." + (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 %) " ") (first 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 (reduce (fn [map item](merge map {(first item)(rest item)})) {} parser-error) + text (first (: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)(first (:column error-map)) 0) + ;; create a cursor to point to that column + cursor (apply str (reverse (conj (repeat column " ") "^"))) + message (bad-parse-error text cursor reason) + ] + (throw (error message)))) + +(defn compile-rule + "Compile this `rule`, assumed to be a string with appropriate syntax, into a function of two arguments, + a `cell` and a `world`, having the same semantics." + [rule] + (assert (string? rule)) + (let [tree (simplify (parse-rule rule))] + (if (rule? tree) #?(:clj (eval (generate tree)) + :cljs (generate tree)) + (throw-parse-exception tree)))) + diff --git a/src/cljs/mw3/utils.cljc b/src/cljs/mw3/utils.cljc new file mode 100644 index 0000000..a2bafab --- /dev/null +++ b/src/cljs/mw3/utils.cljc @@ -0,0 +1,255 @@ +(ns ^:figwheel-always mw3.utils) + +(defn error + [message] + #?(:cljs (js/Error. message) + :clj (Exception. message))) + +(defn abs + "Surprisingly, Clojure doesn't seem to have an abs function, or else I've + missed it. So here's one of my own. Maps natural numbers onto themselves, + and negative integers onto natural numbers. Also maps negative real numbers + onto positive real numbers. + * `n` a number, on the set of real numbers." + [n] + (if (neg? n) (- 0 n) n)) + +(defn member? + "True if elt is a member of col." + [elt col] (some #(= elt %) col)) + +(defn get-int-or-zero + "Return the value of this `property` from this `map` if it is a integer; + otherwise return zero." + [map property] + (let [value (map property)] + (if (integer? value) value 0))) + +(defn init-generation + "Return a cell like this `cell`, but having a value for :generation, zero if + the cell passed had no integer value for generation, otherwise the value + taken from the cell passed. The `world` argument is present only for + consistency with the rule engine and is ignored." + [world cell] + (merge cell {:generation (get-int-or-zero cell :generation)})) + +(defn in-bounds + "True if x, y are in bounds for this world (i.e., there is a cell at x, y) + else false. + * `world` a world as defined above; + * `x` a number which may or may not be a valid x coordinate within that world; + * `y` a number which may or may not be a valid y coordinate within that world." + [world x y] + (and (>= x 0)(>= y 0)(< y (count world))(< x (count (first world))))) + +#?(:cljs + ;; conditional compilation: JavaScript doesn't do parallel mapping. + (defn map-world + "Wholly non-parallel map world implementation" + ([world function] + (map-world world function nil)) + ([world function additional-args] + (into [] + (map (fn [row] + (into [] (map + #(apply function + (cons world (cons % additional-args))) + row))) + world)))) + :clj + (defn map-world + "Apply this `function` to each cell in this `world` to produce a new world. + the arguments to the function will be the world, the cell, and any + `additional-args` supplied. Note that we parallel map over rows but + just map over cells within a row. That's because it isn't worth starting + a new thread for each cell, but there may be efficiency gains in + running rows in parallel." + ([world function] + (map-world world function nil)) + ([world function additional-args] + (into [] + (pmap (fn [row] + (into [] (map + #(apply function + (cons world (cons % additional-args))) + row))) + world))))) + +(defn get-cell + "Return the cell a x, y in this world, if any. + * `world` a world as defined above; + * `x` a number which may or may not be a valid x coordinate within that world; + * `y` a number which may or may not be a valid y coordinate within that world." + [world x y] + (cond (in-bounds world x y) + (nth (nth world y) x))) + +(defn get-int + "Get the value of a property expected to be an integer from a map; if not present (or not an integer) return 0. + * `map` a map; + * `key` a symbol or keyword, presumed to be a key into the `map`." + [map key] + (cond (map? map) + (let [v (map key)] + (cond (and v (integer? v)) v + true 0)) + true (throw (error "No map passed?")))) + +(defn population + "Return the population of this species in this cell. Currently a synonym for + `get-int`, but may not always be (depending whether species are later + implemented as actors) + * `cell` a map; + * `species` a keyword representing a species which may populate that cell." + [cell species] + (get-int cell species)) + +(defn cartesian-product [x-seq y-seq] + (map (fn [n] (map #(list n %)) x-seq) y-seq)) + ;; not right, but nearly + +(def memo-get-neighbours + "Memoised get neighbours is more efficient when running deeply recursive + algorithms on the same world. But it's less efficient when running the + engine in its normal iterative style, because then we will rarely call + get naighbours on the same cell of the same world twice." + (memoize + (fn [world x y depth] + (remove nil? + (map #(get-cell world (first %) (first (rest %))) + (remove #(= % (list x y)) + (cartesian-product + (range (- x depth) (+ x depth 1)) + (range (- y depth) (+ y depth 1))))))))) + +(defn get-neighbours + "Get the neighbours to distance depth of a cell in this world. + Several overloads: + * `world` a world, as described in world.clj; + * `cell` a cell within that world + Gets immediate neighbours of the specified cell. + * `world` a world, as described in world.clj; + * `cell` a cell within that world + * `depth` an integer representing the depth to search from the + `cell` + Gets neighbours within the specified distance of the cell. + * `world` a world, as described in world.clj; + * `x` an integer representing an x coordinate in that world; + * `y` an integer representing an y coordinate in that world; + * `depth` an integer representing the distance from [x,y] that + should be searched + Gets the neighbours within the specified distance of the cell at + coordinates [x,y] in this world." + ([world x y depth] + (remove nil? + (map #(get-cell world (first %) (first (rest %))) + (remove #(= % (list x y)) + (cartesian-product + (range (- x depth) (+ x depth 1)) + (range (- y depth) (+ y depth 1))))))) + ([world cell depth] + (memo-get-neighbours world (:x cell) (:y cell) depth)) + ([world cell] + (get-neighbours world cell 1))) + +;; (defn get-neighbours-with-property-value +;; "Get the neighbours to distance depth of the cell at x, y in this world which +;; have this value for this property. + +;; * `world` a world, as described in `world.clj`; +;; * `cell` a cell within that world; +;; * `depth` an integer representing the distance from [x,y] that +;; should be searched (optional); +;; * `property` a keyword representing a property of the neighbours; +;; * `value` a value of that property (or, possibly, the name of another); +;; * `op` a comparator function to use in place of `=` (optional). + +;; It gets messy." +;; ([world x y depth property value op] +;; (filter +;; #(eval +;; (list op +;; (or (get % property) (get-int % property)) +;; value)) +;; (get-neighbours world x y depth))) +;; ([world x y depth property value] +;; (get-neighbours-with-property-value world x y depth property value =)) +;; ([world cell depth property value] +;; (get-neighbours-with-property-value world (:x cell) (:y cell) depth +;; property value)) +;; ([world cell property value] +;; (get-neighbours-with-property-value world cell 1 +;; property value))) + +(defn get-neighbours-with-state + "Get the neighbours to distance depth of the cell at x, y in this world which + have this state. + * `world` a world, as described in `world.clj`; + * `cell` a cell within that world; + * `depth` an integer representing the distance from [x,y] that + should be searched; + * `state` a keyword representing a state in the world." + ([world x y depth state] + (filter #(= (:state %) state) (get-neighbours world x y depth))) + ([world cell depth state] + (get-neighbours-with-state world (:x cell) (:y cell) depth state)) + ([world cell state] + (get-neighbours-with-state world cell 1 state))) + +(defn get-least-cell + "Return the cell from among these `cells` which has the lowest numeric value + for this `property`; if the property is absent or not a number, use this + `default`" + ([cells property default] + (cond + (empty? cells) nil + true (let [downstream (get-least-cell (rest cells) property default)] + (cond (< + (or (property (first cells)) default) + (or (property downstream) default)) (first cells) + true downstream)))) + ([cells property] + (get-least-cell cells property #?(:cljs 900719925474099 + :clj (Integer/MAX_VALUE))))) + +(defn- set-cell-property + "If this `cell`s x and y properties are equal to these `x` and `y` values, + return a cell like this cell but with the value of this `property` set to + this `value`. Otherwise, just return this `cell`." + [cell x y property value] + (cond + (and (= x (:x cell)) (= y (:y cell))) + (merge cell {property value :rule "Set by user"}) + true + cell)) + +(defn set-property + "Return a world like this `world` but with the value of exactly one `property` + of one `cell` changed to this `value`" + ([world cell property value] + (set-property world (:x cell) (:y cell) property value)) + ([world x y property value] + (apply + vector ;; we want a vector of vectors, not a list of lists, for efficiency + (map + (fn [row] + (apply + vector + (map #(set-cell-property % x y property value) + row))) + world)))) + +(defn merge-cell + "Return a world like this `world`, but merge the values from this `cell` with + those from the cell in the world with the same co-ordinates" + [world cell] + (if (in-bounds world (:x cell) (:y cell)) + (map-world world + #(if + (and + (= (:x cell)(:x %2)) + (= (:y cell)(:y %2))) + (merge %2 cell) + %2)) + world)) + From 94fe77b88367d79b52db1a6ab1fce56dd1d1a08d Mon Sep 17 00:00:00 2001 From: simon Date: Thu, 10 Mar 2016 21:35:10 +0000 Subject: [PATCH 6/6] parser.cljs has been replaced with parser.cljc. --- src/cljs/mw3/parser.cljs | 358 --------------------------------------- 1 file changed, 358 deletions(-) delete mode 100644 src/cljs/mw3/parser.cljs diff --git a/src/cljs/mw3/parser.cljs b/src/cljs/mw3/parser.cljs deleted file mode 100644 index 1ec06cb..0000000 --- a/src/cljs/mw3/parser.cljs +++ /dev/null @@ -1,358 +0,0 @@ -;; (ns ^:figwheel-always mw3.parser -;; (:use mw-engine.utils -;; [clojure.string :only [split trim triml]]) -;; (:require [instaparse.core :as insta])) - - -;; ;; 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") - - -;; (def grammar -;; ;; in order to simplify translation into other natural languages, all -;; ;; TOKENS within the parser should be unambiguous -;; "RULE := IF SPACE CONDITIONS SPACE THEN SPACE ACTIONS; -;; CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | PROPERTY-CONDITION | NEIGHBOURS-CONDITION ; -;; DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS; -;; CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS; -;; CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION; -;; WITHIN-CONDITION := NEIGHBOURS-CONDITION SPACE WITHIN SPACE NUMERIC-EXPRESSION; -;; NEIGHBOURS-CONDITION := WITHIN-CONDITION | QUANTIFIER SPACE NEIGHBOURS SPACE IS SPACE PROPERTY-CONDITION | QUANTIFIER SPACE NEIGHBOURS IS EXPRESSION | QUALIFIER SPACE NEIGHBOURS-CONDITION; -;; PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION; -;; EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE; -;; SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE; -;; DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE; -;; RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION; -;; NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION; -;; NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER; -;; COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN; -;; QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER; -;; QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER; -;; EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ; -;; COMPARATIVE := MORE | LESS; -;; DISJUNCT-VALUE := VALUE | VALUE SPACE OR SPACE DISJUNCT-VALUE; -;; IF := 'if'; -;; THEN := 'then'; -;; THAN := 'than'; -;; OR := 'or'; -;; NOT := 'not'; -;; AND := 'and'; -;; SOME := 'some'; -;; NONE := 'no'; -;; ALL := 'all' -;; BETWEEN := 'between'; -;; WITHIN := 'within'; -;; IN := 'in'; -;; MORE := 'more'; -;; LESS := 'less' | 'fewer'; -;; OPERATOR := '+' | '-' | '*' | '/'; -;; NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors'; -;; PROPERTY := SYMBOL; -;; VALUE := SYMBOL | NUMBER; -;; EQUAL := 'equal to'; -;; IS := 'is' | 'are' | 'have' | 'has'; -;; NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+'; -;; SYMBOL := #'[a-z]+'; -;; ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS -;; ACTION := SIMPLE-ACTION | PROBABLE-ACTION; -;; PROBABLE-ACTION := VALUE SPACE 'chance in' SPACE VALUE SPACE SIMPLE-ACTION; -;; SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION -;; BECOMES := 'should be' -;; 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-condition -;; "Generate a property condition where the expression is a disjunct 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) -;; (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-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] -;; nil) -;; ;; (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment") -;; ;; (conj 'do (map - -;; (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] -;; (generate-neighbours-condition tree (first (second tree)))) -;; ([tree quantifier-type] -;; (let [quantifier (second (second tree)) -;; pc (generate (nth tree 4))] -;; (case quantifier-type -;; :NUMBER (generate-neighbours-condition '= (read-string quantifier) pc 1) -;; :SOME (generate-neighbours-condition '> 0 pc 1) -;; :QUANTIFIER -;; (let [comparative (generate (simplify (second quantifier))) -;; value (simplify (nth quantifier 5))] -;; (generate-neighbours-condition comparative value pc 1))))) -;; ([comp1 quantity property-condition distance] -;; (list comp1 -;; (list 'count (list 'remove false (list 'map (list 'fn ['cell] property-condition) '(get-neighbours cell world distance)))) quantity)) -;; ([comp1 quantity property-condition] -;; (generate-neighbours-condition comp1 quantity property-condition 1))) - -;; ;; (def s1 "if 3 neighbours have state equal to forest then state should be forest") -;; ;; (def s2 "if some neighbours have state equal to forest then state should be forest") -;; ;; (def s3 "if more than 3 neighbours have state equal to forest then state should be forest") -;; ;; (def s4 "if fewer than 3 neighbours have state equal to forest then state should be forest") -;; ;; (def s5 "if all neighbours have state equal to forest then state should be forest") -;; ;; (def s6 "if more than 3 neighbours within 2 have state equal to forest then state should be forest") - -;; ;; (nth (simplify (parse-rule s1)) 2) -;; ;; (second (nth (simplify (parse-rule s1)) 2)) -;; ;; (nth (simplify (parse-rule s2)) 2) -;; ;; (map simplify (nth (simplify (parse-rule s2)) 2)) -;; ;; ;; (second (nth (simplify (parse-rule s2)) 2)) -;; ;; ;; (nth (simplify (parse-rule s3)) 2) -;; ;; (second (nth (simplify (parse-rule s3)) 2)) -;; ;; (map simplify (second (nth (simplify (parse-rule s3)) 2))) -;; ;; ;; (nth (simplify (parse-rule s4)) 2) -;; ;; ;; (second (nth (simplify (parse-rule s4)) 2)) -;; ;; ;; (nth (simplify (parse-rule s5)) 2) -;; ;; ;; (second (nth (simplify (parse-rule s5)) 2)) -;; ;; ;; (nth (simplify (parse-rule s6)) 2) -;; ;; ;; (second (nth (simplify (parse-rule s6)) 2)) - -;; ;; ;; (generate (nth (nth (simplify (parse-rule s5)) 2) 4)) -;; ;; ;; (generate (nth (simplify (parse-rule s2)) 2)) -;; ;; ;; (generate (nth (simplify (parse-rule s1)) 2)) - - -;; ;; (generate-neighbours-condition '= 3 '(= (:state cell) :forest) 1) -;; ;; (generate-neighbours-condition (nth (simplify (parse-rule s3)) 2)) -;; ;; (generate-neighbours-condition (nth (simplify (parse-rule s2)) 2)) -;; ;; (generate-neighbours-condition (nth (simplify (parse-rule s1)) 2)) - - -;; (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) -;; ;; :QUANTIFIER (simplify-second-of-two tree) -;; :NOT nil -;; :PROPERTY (simplify-second-of-two tree) -;; :SPACE nil -;; :THEN nil -;; ;; :QUALIFIER (simplify-qualifier tree) -;; :VALUE (simplify-second-of-two tree) -;; (remove nil? (map simplify tree))) -;; tree)) - -;; (def parse-rule -;; "Parse the argument, assumed to be a string in the correct syntax, and return a parse tree." -;; (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 %) " ") (first 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 (reduce (fn [map item](merge map {(first item)(rest item)})) {} parser-error) -;; text (first (: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)(first (: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 -;; "Compile this `rule`, assumed to be a string with appropriate syntax, into a function of two arguments, -;; a `cell` and a `world`, having the same semantics." -;; [rule] -;; (assert (string? rule)) -;; (let [tree (simplify (parse-rule rule))] -;; (if (rule? tree) (eval (generate tree)) -;; (throw-parse-exception tree)))) - -