Merge branch 'beforethebreak'
This commit is contained in:
commit
85a51f4591
|
|
@ -4,7 +4,8 @@
|
||||||
(:require
|
(:require
|
||||||
[mw3.rulesets :as rulesets]
|
[mw3.rulesets :as rulesets]
|
||||||
[dommy.core :as dommy :refer-macros [sel sel1]]
|
[dommy.core :as dommy :refer-macros [sel sel1]]
|
||||||
[dommy.template :as temp]))
|
[dommy.template :as temp]
|
||||||
|
))
|
||||||
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
@ -78,82 +79,47 @@
|
||||||
;; Rules page
|
;; Rules page
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(defn ^:export rule-ok-click-handler
|
||||||
|
"Handle the click action on the rule `ok` button with this `index`."
|
||||||
|
[index]
|
||||||
|
(let [rule-input (sel1 (keyword (str "#rule-input-" index)))
|
||||||
|
rule-text (if rule-input (dommy/attr rule-input :value) "Rule input not found")]
|
||||||
|
(.log js/console (str "rule-ok-click-handler called with index " index ": " rule-text))))
|
||||||
|
|
||||||
(deftemplate rule-editor
|
(deftemplate rule-editor
|
||||||
;; "Constructs an editor for this `rule` with this `index`, given this `total`
|
;; "Constructs an editor for this `rule` with this `index`
|
||||||
;; number of rules.
|
[rule index]
|
||||||
[rule index total]
|
|
||||||
[:div
|
[:div
|
||||||
{:id (str "rule-editor-" index) :class "rule-editor"}
|
{:id (str "rule-editor-" index) :class "rule-editor"}
|
||||||
[:input {:type "text" :id (str "rule-input-" index) :class "rule-input" :value rule}]
|
[:input {:type "text" :id (str "rule-input-" index) :class "rule-input" :value rule}]
|
||||||
[:div {:id (str "rule-controls-" index) :class "rule-controls"}
|
[:div {:id (str "rule-controls-" index) :class "rule-controls"}
|
||||||
[:input {:type "button"
|
[:input {:type "button" :id (str "rule-ok-" index) :class "rule-ok" :value "ok"
|
||||||
:id (str "rule-ok-" index)
|
:onclick (str "mw3.core.rule_ok_click_handler(" index ")")}] ;; ✔
|
||||||
:class "rule-ok"
|
[:input {:type "button" :id (str "rule-up-" index) :class "rule-up" :value "up"}] ;; ↑
|
||||||
:value "ok"}] ;; ✔
|
[:input {:type "button" :id (str "rule-down-" index) :class "rule-down" :value "down"}] ;; ↓
|
||||||
[:input {:type "button"
|
[:input {:type "button" :id (str "rule-delete-" index) :class "rule-delete" :value "delete"}]] ;; ✘
|
||||||
:id (str "rule-up-" index)
|
[:pre {:id (str "rule-feedback-" index) :class "rule-feedback"}]
|
||||||
: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"}]])
|
|
||||||
|
|
||||||
(defn rule-up-handler
|
;; (deftemplate rule-editors
|
||||||
"A handler to move the rule with index `n` one place up the list."
|
;; ;; Constructs, as a `div`, a set of rule editors for the rules in the ruleset with
|
||||||
[n id]
|
;; ;; this `ruleset-name`.
|
||||||
(.log js/console (str id " pressed")))
|
;; [ruleset-name]
|
||||||
|
;; [:div
|
||||||
(defn rule-down-handler
|
;; (vec
|
||||||
"A handler to move the rule with index `n` one place down the list."
|
;; (map
|
||||||
[n id]
|
;; #(rule-editor % %)
|
||||||
(.log js/console (str id " pressed")))
|
;; (rulesets/rulesets ruleset-name)
|
||||||
|
;; (range)))])
|
||||||
(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
|
(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]
|
[name]
|
||||||
(let [rules-container (sel1 :#rules-container)
|
(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)
|
(dommy/clear! rules-container)
|
||||||
(doseq [[rule index] indexed-rules]
|
(doseq [[rule index] (map #(list %1 %2) ruleset (range (count ruleset)))]
|
||||||
(dommy/append! rules-container (rule-editor rule index total)))
|
(dommy/append! rules-container (rule-editor rule index)))))
|
||||||
(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
|
;; Set up the screen on loading
|
||||||
|
|
|
||||||
329
src/cljs/mw3/parser.cljc
Normal file
329
src/cljs/mw3/parser.cljc
Normal file
|
|
@ -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))))
|
||||||
|
|
||||||
255
src/cljs/mw3/utils.cljc
Normal file
255
src/cljs/mw3/utils.cljc
Normal file
|
|
@ -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))
|
||||||
|
|
||||||
Loading…
Reference in a new issue