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.
This commit is contained in:
parent
1d23b45dbd
commit
3bd1d7f298
|
|
@ -78,41 +78,82 @@
|
||||||
;; Rules page
|
;; Rules page
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(deftemplate rule-editor
|
(deftemplate rule-editor
|
||||||
;; "Constructs an editor for this `rule` with this `index`
|
;; "Constructs an editor for this `rule` with this `index`, given this `total`
|
||||||
[rule index]
|
;; number of rules.
|
||||||
|
[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" :id (str "rule-ok-" index) :class "rule-ok" :value "ok"}] ;; ✔
|
[:input {:type "button"
|
||||||
[:input {:type "button" :id (str "rule-up-" index) :class "rule-up" :value "up"}] ;; ↑
|
:id (str "rule-ok-" index)
|
||||||
[:input {:type "button" :id (str "rule-down-" index) :class "rule-down" :value "down"}] ;; ↓
|
:class "rule-ok"
|
||||||
[:input {:type "button" :id (str "rule-delete-" index) :class "rule-delete" :value "delete"}]] ;; ✘
|
:value "ok"}] ;; ✔
|
||||||
[:pre {:id (str "rule-feedback-" index) :class "rule-feedback"}]
|
[: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
|
(defn rule-up-handler
|
||||||
;; ;; Constructs, as a `div`, a set of rule editors for the rules in the ruleset with
|
"A handler to move the rule with index `n` one place up the list."
|
||||||
;; ;; this `ruleset-name`.
|
[n id]
|
||||||
;; [ruleset-name]
|
(.log js/console (str id " pressed")))
|
||||||
;; [:div
|
|
||||||
;; (vec
|
(defn rule-down-handler
|
||||||
;; (map
|
"A handler to move the rule with index `n` one place down the list."
|
||||||
;; #(rule-editor % %)
|
[n id]
|
||||||
;; (rulesets/rulesets ruleset-name)
|
(.log js/console (str id " pressed")))
|
||||||
;; (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] (map #(list %1 %2) ruleset (range (count ruleset)))]
|
(doseq [[rule index] indexed-rules]
|
||||||
(dommy/append! rules-container (rule-editor rule index)))))
|
(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
|
;; Set up the screen on loading
|
||||||
|
|
|
||||||
|
|
@ -1,358 +1,358 @@
|
||||||
(ns ^:figwheel-always mw3.parser
|
;; (ns ^:figwheel-always mw3.parser
|
||||||
(:use mw-engine.utils
|
;; (:use mw-engine.utils
|
||||||
[clojure.string :only [split trim triml]])
|
;; [clojure.string :only [split trim triml]])
|
||||||
(:require [instaparse.core :as insta]))
|
;; (:require [instaparse.core :as insta]))
|
||||||
|
|
||||||
|
|
||||||
;; error thrown when an attempt is made to set a reserved property
|
;; ;; error thrown when an attempt is made to set a reserved property
|
||||||
(def reserved-properties-error
|
;; (def reserved-properties-error
|
||||||
"The properties 'x' and 'y' of a cell are reserved and should not be set in rule actions")
|
;; "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
|
;; ;; error thrown when a rule cannot be parsed. Slots are for
|
||||||
;; (1) rule text
|
;; ;; (1) rule text
|
||||||
;; (2) cursor showing where in the rule text the error occurred
|
;; ;; (2) cursor showing where in the rule text the error occurred
|
||||||
;; (3) the reason for the error
|
;; ;; (3) the reason for the error
|
||||||
(def bad-parse-error "I did not understand:\n'%s'\n%s\n%s")
|
;; (def bad-parse-error "I did not understand:\n'%s'\n%s\n%s")
|
||||||
|
|
||||||
|
|
||||||
(def grammar
|
;; (def grammar
|
||||||
;; in order to simplify translation into other natural languages, all
|
;; ;; in order to simplify translation into other natural languages, all
|
||||||
;; TOKENS within the parser should be unambiguous
|
;; ;; TOKENS within the parser should be unambiguous
|
||||||
"RULE := IF SPACE CONDITIONS SPACE THEN SPACE ACTIONS;
|
;; "RULE := IF SPACE CONDITIONS SPACE THEN SPACE ACTIONS;
|
||||||
CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | PROPERTY-CONDITION | NEIGHBOURS-CONDITION ;
|
;; CONDITIONS := DISJUNCT-CONDITION | CONJUNCT-CONDITION | PROPERTY-CONDITION | NEIGHBOURS-CONDITION ;
|
||||||
DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS;
|
;; DISJUNCT-CONDITION := CONDITION SPACE OR SPACE CONDITIONS;
|
||||||
CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS;
|
;; CONJUNCT-CONDITION := CONDITION SPACE AND SPACE CONDITIONS;
|
||||||
CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION;
|
;; CONDITION := NEIGHBOURS-CONDITION | PROPERTY-CONDITION;
|
||||||
WITHIN-CONDITION := NEIGHBOURS-CONDITION SPACE WITHIN SPACE NUMERIC-EXPRESSION;
|
;; 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;
|
;; 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;
|
;; PROPERTY-CONDITION := PROPERTY SPACE QUALIFIER SPACE EXPRESSION;
|
||||||
EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE;
|
;; EXPRESSION := SIMPLE-EXPRESSION | RANGE-EXPRESSION | NUMERIC-EXPRESSION | DISJUNCT-EXPRESSION | VALUE;
|
||||||
SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE;
|
;; SIMPLE-EXPRESSION := QUALIFIER SPACE EXPRESSION | VALUE;
|
||||||
DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE;
|
;; DISJUNCT-EXPRESSION := IN SPACE DISJUNCT-VALUE;
|
||||||
RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION;
|
;; RANGE-EXPRESSION := BETWEEN SPACE NUMERIC-EXPRESSION SPACE AND SPACE NUMERIC-EXPRESSION;
|
||||||
NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION;
|
;; NUMERIC-EXPRESSION := VALUE | VALUE SPACE OPERATOR SPACE NUMERIC-EXPRESSION;
|
||||||
NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER;
|
;; NEGATED-QUALIFIER := QUALIFIER SPACE NOT | NOT SPACE QUALIFIER;
|
||||||
COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN;
|
;; COMPARATIVE-QUALIFIER := IS SPACE COMPARATIVE SPACE THAN;
|
||||||
QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER;
|
;; QUALIFIER := COMPARATIVE-QUALIFIER | NEGATED-QUALIFIER | EQUIVALENCE | IS SPACE QUALIFIER;
|
||||||
QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER;
|
;; QUANTIFIER := NUMBER | SOME | NONE | ALL | COMPARATIVE SPACE THAN SPACE NUMBER;
|
||||||
EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ;
|
;; EQUIVALENCE := IS SPACE EQUAL | EQUAL | IS ;
|
||||||
COMPARATIVE := MORE | LESS;
|
;; COMPARATIVE := MORE | LESS;
|
||||||
DISJUNCT-VALUE := VALUE | VALUE SPACE OR SPACE DISJUNCT-VALUE;
|
;; DISJUNCT-VALUE := VALUE | VALUE SPACE OR SPACE DISJUNCT-VALUE;
|
||||||
IF := 'if';
|
;; IF := 'if';
|
||||||
THEN := 'then';
|
;; THEN := 'then';
|
||||||
THAN := 'than';
|
;; THAN := 'than';
|
||||||
OR := 'or';
|
;; OR := 'or';
|
||||||
NOT := 'not';
|
;; NOT := 'not';
|
||||||
AND := 'and';
|
;; AND := 'and';
|
||||||
SOME := 'some';
|
;; SOME := 'some';
|
||||||
NONE := 'no';
|
;; NONE := 'no';
|
||||||
ALL := 'all'
|
;; ALL := 'all'
|
||||||
BETWEEN := 'between';
|
;; BETWEEN := 'between';
|
||||||
WITHIN := 'within';
|
;; WITHIN := 'within';
|
||||||
IN := 'in';
|
;; IN := 'in';
|
||||||
MORE := 'more';
|
;; MORE := 'more';
|
||||||
LESS := 'less' | 'fewer';
|
;; LESS := 'less' | 'fewer';
|
||||||
OPERATOR := '+' | '-' | '*' | '/';
|
;; OPERATOR := '+' | '-' | '*' | '/';
|
||||||
NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors';
|
;; NEIGHBOURS := 'neighbour' | 'neighbor' | 'neighbours' | 'neighbors';
|
||||||
PROPERTY := SYMBOL;
|
;; PROPERTY := SYMBOL;
|
||||||
VALUE := SYMBOL | NUMBER;
|
;; VALUE := SYMBOL | NUMBER;
|
||||||
EQUAL := 'equal to';
|
;; EQUAL := 'equal to';
|
||||||
IS := 'is' | 'are' | 'have' | 'has';
|
;; IS := 'is' | 'are' | 'have' | 'has';
|
||||||
NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+';
|
;; NUMBER := #'[0-9]+' | #'[0-9]+.[0-9]+';
|
||||||
SYMBOL := #'[a-z]+';
|
;; SYMBOL := #'[a-z]+';
|
||||||
ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS
|
;; ACTIONS := ACTION | ACTION SPACE 'and' SPACE ACTIONS
|
||||||
ACTION := SIMPLE-ACTION | PROBABLE-ACTION;
|
;; ACTION := SIMPLE-ACTION | PROBABLE-ACTION;
|
||||||
PROBABLE-ACTION := VALUE SPACE 'chance in' SPACE VALUE SPACE SIMPLE-ACTION;
|
;; PROBABLE-ACTION := VALUE SPACE 'chance in' SPACE VALUE SPACE SIMPLE-ACTION;
|
||||||
SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION
|
;; SIMPLE-ACTION := SYMBOL SPACE BECOMES SPACE EXPRESSION
|
||||||
BECOMES := 'should be'
|
;; BECOMES := 'should be'
|
||||||
SPACE := #' *'"
|
;; SPACE := #' *'"
|
||||||
)
|
;; )
|
||||||
|
|
||||||
(defn TODO
|
;; (defn TODO
|
||||||
"Marker to indicate I'm not yet finished!"
|
;; "Marker to indicate I'm not yet finished!"
|
||||||
[message]
|
;; [message]
|
||||||
message)
|
;; message)
|
||||||
|
|
||||||
|
|
||||||
(declare generate simplify)
|
;; (declare generate simplify)
|
||||||
|
|
||||||
(defn suitable-fragment?
|
;; (defn suitable-fragment?
|
||||||
"Return `true` if `tree-fragment` appears to be a tree fragment of the expected `type`."
|
;; "Return `true` if `tree-fragment` appears to be a tree fragment of the expected `type`."
|
||||||
[tree-fragment type]
|
;; [tree-fragment type]
|
||||||
(and (coll? tree-fragment)(= (first tree-fragment) type)))
|
;; (and (coll? tree-fragment)(= (first tree-fragment) type)))
|
||||||
|
|
||||||
(defn assert-type
|
;; (defn assert-type
|
||||||
"If `tree-fragment` is not a tree fragment of the expected `type`, throw an exception."
|
;; "If `tree-fragment` is not a tree fragment of the expected `type`, throw an exception."
|
||||||
[tree-fragment type]
|
;; [tree-fragment type]
|
||||||
(assert (suitable-fragment? tree-fragment type)
|
;; (assert (suitable-fragment? tree-fragment type)
|
||||||
(throw (Exception. (format "Expected a %s fragment" type)))))
|
;; (throw (Exception. (format "Expected a %s fragment" type)))))
|
||||||
|
|
||||||
(defn generate-rule
|
;; (defn generate-rule
|
||||||
"From this `tree`, assumed to be a syntactically correct rule specification,
|
;; "From this `tree`, assumed to be a syntactically correct rule specification,
|
||||||
generate and return the appropriate rule as a function of two arguments."
|
;; generate and return the appropriate rule as a function of two arguments."
|
||||||
[tree]
|
;; [tree]
|
||||||
(assert-type tree :RULE)
|
;; (assert-type tree :RULE)
|
||||||
(list 'fn ['cell 'world] (list 'if (generate (nth tree 2)) (generate (nth tree 3)))))
|
;; (list 'fn ['cell 'world] (list 'if (generate (nth tree 2)) (generate (nth tree 3)))))
|
||||||
|
|
||||||
(defn generate-conditions
|
;; (defn generate-conditions
|
||||||
"From this `tree`, assumed to be a syntactically correct conditions clause,
|
;; "From this `tree`, assumed to be a syntactically correct conditions clause,
|
||||||
generate and return the appropriate clojure fragment."
|
;; generate and return the appropriate clojure fragment."
|
||||||
[tree]
|
;; [tree]
|
||||||
(assert-type tree :CONDITIONS)
|
;; (assert-type tree :CONDITIONS)
|
||||||
(generate (nth tree 1)))
|
;; (generate (nth tree 1)))
|
||||||
|
|
||||||
(defn generate-condition
|
;; (defn generate-condition
|
||||||
[tree]
|
;; [tree]
|
||||||
(assert-type tree :CONDITION)
|
;; (assert-type tree :CONDITION)
|
||||||
(generate (nth tree 1)))
|
;; (generate (nth tree 1)))
|
||||||
|
|
||||||
(defn generate-conjunct-condition
|
;; (defn generate-conjunct-condition
|
||||||
[tree]
|
;; [tree]
|
||||||
(assert-type tree :CONJUNCT-CONDITION)
|
;; (assert-type tree :CONJUNCT-CONDITION)
|
||||||
(list 'and (generate (nth tree 1))(generate (nth tree 3))))
|
;; (list 'and (generate (nth tree 1))(generate (nth tree 3))))
|
||||||
|
|
||||||
(defn generate-disjunct-condition
|
;; (defn generate-disjunct-condition
|
||||||
[tree]
|
;; [tree]
|
||||||
(assert-type tree :DISJUNCT-CONDITION)
|
;; (assert-type tree :DISJUNCT-CONDITION)
|
||||||
(list 'or (generate (nth tree 1))(generate (nth tree 3))))
|
;; (list 'or (generate (nth tree 1))(generate (nth tree 3))))
|
||||||
|
|
||||||
(defn generate-ranged-property-condition
|
;; (defn generate-ranged-property-condition
|
||||||
"Generate a property condition where the expression is a numeric range"
|
;; "Generate a property condition where the expression is a numeric range"
|
||||||
[tree property expression]
|
;; [tree property expression]
|
||||||
(assert-type tree :PROPERTY-CONDITION)
|
;; (assert-type tree :PROPERTY-CONDITION)
|
||||||
(assert-type (nth tree 3) :RANGE-EXPRESSION)
|
;; (assert-type (nth tree 3) :RANGE-EXPRESSION)
|
||||||
(let [l1 (generate (nth expression 2))
|
;; (let [l1 (generate (nth expression 2))
|
||||||
l2 (generate (nth expression 4))
|
;; l2 (generate (nth expression 4))
|
||||||
pv (list property 'cell)]
|
;; pv (list property 'cell)]
|
||||||
(list 'let ['lower (list 'min l1 l2)
|
;; (list 'let ['lower (list 'min l1 l2)
|
||||||
'upper (list 'max l1 l2)]
|
;; 'upper (list 'max l1 l2)]
|
||||||
(list 'and (list '>= pv 'lower)(list '<= pv 'upper)))))
|
;; (list 'and (list '>= pv 'lower)(list '<= pv 'upper)))))
|
||||||
|
|
||||||
(defn generate-disjunct-condition
|
;; (defn generate-disjunct-condition
|
||||||
"Generate a property condition where the expression is a disjunct expression"
|
;; "Generate a property condition where the expression is a disjunct expression"
|
||||||
[tree property qualifier expression]
|
;; [tree property qualifier expression]
|
||||||
(let [e (list 'some (list 'fn ['i] '(= i value)) (list 'quote expression))]
|
;; (let [e (list 'some (list 'fn ['i] '(= i value)) (list 'quote expression))]
|
||||||
(list 'let ['value (list property 'cell)]
|
;; (list 'let ['value (list property 'cell)]
|
||||||
(if (= qualifier '=) e
|
;; (if (= qualifier '=) e
|
||||||
(list 'not e)))))
|
;; (list 'not e)))))
|
||||||
|
|
||||||
(defn generate-property-condition
|
;; (defn generate-property-condition
|
||||||
([tree]
|
;; ([tree]
|
||||||
(assert-type tree :PROPERTY-CONDITION)
|
;; (assert-type tree :PROPERTY-CONDITION)
|
||||||
(generate-property-condition tree (first (nth tree 3))))
|
;; (generate-property-condition tree (first (nth tree 3))))
|
||||||
([tree expression-type]
|
;; ([tree expression-type]
|
||||||
(assert-type tree :PROPERTY-CONDITION)
|
;; (assert-type tree :PROPERTY-CONDITION)
|
||||||
(let [property (generate (nth tree 1))
|
;; (let [property (generate (nth tree 1))
|
||||||
qualifier (generate (nth tree 2))
|
;; qualifier (generate (nth tree 2))
|
||||||
expression (generate (nth tree 3))]
|
;; expression (generate (nth tree 3))]
|
||||||
(case expression-type
|
;; (case expression-type
|
||||||
:DISJUNCT-EXPRESSION (generate-disjunct-condition tree property qualifier expression)
|
;; :DISJUNCT-EXPRESSION (generate-disjunct-condition tree property qualifier expression)
|
||||||
:RANGE-EXPRESSION (generate-ranged-property-condition tree property expression)
|
;; :RANGE-EXPRESSION (generate-ranged-property-condition tree property expression)
|
||||||
(list qualifier (list property 'cell) expression)))))
|
;; (list qualifier (list property 'cell) expression)))))
|
||||||
|
|
||||||
(defn generate-simple-action
|
;; (defn generate-simple-action
|
||||||
[tree]
|
;; [tree]
|
||||||
(assert-type tree :SIMPLE-ACTION)
|
;; (assert-type tree :SIMPLE-ACTION)
|
||||||
(let [property (generate (nth tree 1))
|
;; (let [property (generate (nth tree 1))
|
||||||
expression (generate (nth tree 3))]
|
;; expression (generate (nth tree 3))]
|
||||||
(if (or (= property :x) (= property :y))
|
;; (if (or (= property :x) (= property :y))
|
||||||
(throw (Exception. reserved-properties-error))
|
;; (throw (Exception. reserved-properties-error))
|
||||||
(list 'merge 'cell {property expression}))))
|
;; (list 'merge 'cell {property expression}))))
|
||||||
|
|
||||||
(defn generate-multiple-actions
|
;; (defn generate-multiple-actions
|
||||||
[tree]
|
;; [tree]
|
||||||
nil)
|
;; nil)
|
||||||
;; (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment")
|
;; ;; (assert (and (coll? tree)(= (first tree) :ACTIONS)) "Expected an ACTIONS fragment")
|
||||||
;; (conj 'do (map
|
;; ;; (conj 'do (map
|
||||||
|
|
||||||
(defn generate-disjunct-value
|
;; (defn generate-disjunct-value
|
||||||
"Generate a disjunct value. Essentially what we need here is to generate a
|
;; "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."
|
;; flat list of values, since the `member` has already been taken care of."
|
||||||
[tree]
|
;; [tree]
|
||||||
(assert-type tree :DISJUNCT-VALUE)
|
;; (assert-type tree :DISJUNCT-VALUE)
|
||||||
(if (= (count tree) 4)
|
;; (if (= (count tree) 4)
|
||||||
(cons (generate (second tree)) (generate (nth tree 3)))
|
;; (cons (generate (second tree)) (generate (nth tree 3)))
|
||||||
(list (generate (second tree)))))
|
;; (list (generate (second tree)))))
|
||||||
|
|
||||||
(defn generate-numeric-expression
|
;; (defn generate-numeric-expression
|
||||||
[tree]
|
;; [tree]
|
||||||
(assert-type tree :NUMERIC-EXPRESSION)
|
;; (assert-type tree :NUMERIC-EXPRESSION)
|
||||||
(case (first (second tree))
|
;; (case (first (second tree))
|
||||||
:SYMBOL (list (keyword (second (second tree))) 'cell)
|
;; :SYMBOL (list (keyword (second (second tree))) 'cell)
|
||||||
(generate (second tree))))
|
;; (generate (second tree))))
|
||||||
|
|
||||||
(defn generate-neighbours-condition
|
;; (defn generate-neighbours-condition
|
||||||
"Generate code for a condition which refers to neighbours."
|
;; "Generate code for a condition which refers to neighbours."
|
||||||
([tree]
|
;; ([tree]
|
||||||
(generate-neighbours-condition tree (first (second tree))))
|
;; (generate-neighbours-condition tree (first (second tree))))
|
||||||
([tree quantifier-type]
|
;; ([tree quantifier-type]
|
||||||
(let [quantifier (second (second tree))
|
;; (let [quantifier (second (second tree))
|
||||||
pc (generate (nth tree 4))]
|
;; pc (generate (nth tree 4))]
|
||||||
(case quantifier-type
|
;; (case quantifier-type
|
||||||
:NUMBER (generate-neighbours-condition '= (read-string quantifier) pc 1)
|
;; :NUMBER (generate-neighbours-condition '= (read-string quantifier) pc 1)
|
||||||
:SOME (generate-neighbours-condition '> 0 pc 1)
|
;; :SOME (generate-neighbours-condition '> 0 pc 1)
|
||||||
:QUANTIFIER
|
;; :QUANTIFIER
|
||||||
(let [comparative (generate (simplify (second quantifier)))
|
;; (let [comparative (generate (simplify (second quantifier)))
|
||||||
value (simplify (nth quantifier 5))]
|
;; value (simplify (nth quantifier 5))]
|
||||||
(generate-neighbours-condition comparative value pc 1)))))
|
;; (generate-neighbours-condition comparative value pc 1)))))
|
||||||
([comp1 quantity property-condition distance]
|
;; ([comp1 quantity property-condition distance]
|
||||||
(list comp1
|
;; (list comp1
|
||||||
(list 'count (list 'remove false (list 'map (list 'fn ['cell] property-condition) '(get-neighbours cell world distance)))) quantity))
|
;; (list 'count (list 'remove false (list 'map (list 'fn ['cell] property-condition) '(get-neighbours cell world distance)))) quantity))
|
||||||
([comp1 quantity property-condition]
|
;; ([comp1 quantity property-condition]
|
||||||
(generate-neighbours-condition comp1 quantity property-condition 1)))
|
;; (generate-neighbours-condition comp1 quantity property-condition 1)))
|
||||||
|
|
||||||
;; (def s1 "if 3 neighbours 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 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 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 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 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 s6 "if more than 3 neighbours within 2 have state equal to forest then state should be forest")
|
||||||
|
|
||||||
;; (nth (simplify (parse-rule s1)) 2)
|
;; ;; (nth (simplify (parse-rule s1)) 2)
|
||||||
;; (second (nth (simplify (parse-rule s1)) 2))
|
;; ;; (second (nth (simplify (parse-rule s1)) 2))
|
||||||
;; (nth (simplify (parse-rule s2)) 2)
|
;; ;; (nth (simplify (parse-rule s2)) 2)
|
||||||
;; (map simplify (nth (simplify (parse-rule s2)) 2))
|
;; ;; (map simplify (nth (simplify (parse-rule s2)) 2))
|
||||||
;; ;; (second (nth (simplify (parse-rule s2)) 2))
|
;; ;; ;; (second (nth (simplify (parse-rule s2)) 2))
|
||||||
;; ;; (nth (simplify (parse-rule s3)) 2)
|
;; ;; ;; (nth (simplify (parse-rule s3)) 2)
|
||||||
;; (second (nth (simplify (parse-rule s3)) 2))
|
;; ;; (second (nth (simplify (parse-rule s3)) 2))
|
||||||
;; (map simplify (second (nth (simplify (parse-rule s3)) 2)))
|
;; ;; (map simplify (second (nth (simplify (parse-rule s3)) 2)))
|
||||||
;; ;; (nth (simplify (parse-rule s4)) 2)
|
;; ;; ;; (nth (simplify (parse-rule s4)) 2)
|
||||||
;; ;; (second (nth (simplify (parse-rule s4)) 2))
|
;; ;; ;; (second (nth (simplify (parse-rule s4)) 2))
|
||||||
;; ;; (nth (simplify (parse-rule s5)) 2)
|
;; ;; ;; (nth (simplify (parse-rule s5)) 2)
|
||||||
;; ;; (second (nth (simplify (parse-rule s5)) 2))
|
;; ;; ;; (second (nth (simplify (parse-rule s5)) 2))
|
||||||
;; ;; (nth (simplify (parse-rule s6)) 2)
|
;; ;; ;; (nth (simplify (parse-rule s6)) 2)
|
||||||
;; ;; (second (nth (simplify (parse-rule s6)) 2))
|
;; ;; ;; (second (nth (simplify (parse-rule s6)) 2))
|
||||||
|
|
||||||
;; ;; (generate (nth (nth (simplify (parse-rule s5)) 2) 4))
|
;; ;; ;; (generate (nth (nth (simplify (parse-rule s5)) 2) 4))
|
||||||
;; ;; (generate (nth (simplify (parse-rule s2)) 2))
|
;; ;; ;; (generate (nth (simplify (parse-rule s2)) 2))
|
||||||
;; ;; (generate (nth (simplify (parse-rule s1)) 2))
|
;; ;; ;; (generate (nth (simplify (parse-rule s1)) 2))
|
||||||
|
|
||||||
|
|
||||||
;; (generate-neighbours-condition '= 3 '(= (:state cell) :forest) 1)
|
;; ;; (generate-neighbours-condition '= 3 '(= (:state cell) :forest) 1)
|
||||||
;; (generate-neighbours-condition (nth (simplify (parse-rule s3)) 2))
|
;; ;; (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 s2)) 2))
|
||||||
;; (generate-neighbours-condition (nth (simplify (parse-rule s1)) 2))
|
;; ;; (generate-neighbours-condition (nth (simplify (parse-rule s1)) 2))
|
||||||
|
|
||||||
|
|
||||||
(defn generate
|
;; (defn generate
|
||||||
"Generate code for this (fragment of a) parse tree"
|
;; "Generate code for this (fragment of a) parse tree"
|
||||||
[tree]
|
;; [tree]
|
||||||
(if
|
;; (if
|
||||||
(coll? tree)
|
;; (coll? tree)
|
||||||
(case (first tree)
|
;; (case (first tree)
|
||||||
:ACTIONS (generate-multiple-actions tree)
|
;; :ACTIONS (generate-multiple-actions tree)
|
||||||
:COMPARATIVE (generate (second tree))
|
;; :COMPARATIVE (generate (second tree))
|
||||||
:COMPARATIVE-QUALIFIER (generate (nth tree 2))
|
;; :COMPARATIVE-QUALIFIER (generate (nth tree 2))
|
||||||
:CONDITION (generate-condition tree)
|
;; :CONDITION (generate-condition tree)
|
||||||
:CONDITIONS (generate-conditions tree)
|
;; :CONDITIONS (generate-conditions tree)
|
||||||
:CONJUNCT-CONDITION (generate-conjunct-condition tree)
|
;; :CONJUNCT-CONDITION (generate-conjunct-condition tree)
|
||||||
:DISJUNCT-CONDITION (generate-disjunct-condition tree)
|
;; :DISJUNCT-CONDITION (generate-disjunct-condition tree)
|
||||||
:DISJUNCT-EXPRESSION (generate (nth tree 2))
|
;; :DISJUNCT-EXPRESSION (generate (nth tree 2))
|
||||||
:DISJUNCT-VALUE (generate-disjunct-value tree)
|
;; :DISJUNCT-VALUE (generate-disjunct-value tree)
|
||||||
:EQUIVALENCE '=
|
;; :EQUIVALENCE '=
|
||||||
:EXPRESSION (generate (second tree))
|
;; :EXPRESSION (generate (second tree))
|
||||||
:LESS '<
|
;; :LESS '<
|
||||||
:MORE '>
|
;; :MORE '>
|
||||||
:NEGATED-QUALIFIER (case (generate (second tree))
|
;; :NEGATED-QUALIFIER (case (generate (second tree))
|
||||||
= 'not=
|
;; = 'not=
|
||||||
> '<
|
;; > '<
|
||||||
< '>)
|
;; < '>)
|
||||||
:NEIGHBOURS-CONDITION (generate-neighbours-condition tree)
|
;; :NEIGHBOURS-CONDITION (generate-neighbours-condition tree)
|
||||||
:NUMERIC-EXPRESSION (generate-numeric-expression tree)
|
;; :NUMERIC-EXPRESSION (generate-numeric-expression tree)
|
||||||
:NUMBER (read-string (second tree))
|
;; :NUMBER (read-string (second tree))
|
||||||
:PROPERTY (list (generate (second tree)) 'cell) ;; dubious - may not be right
|
;; :PROPERTY (list (generate (second tree)) 'cell) ;; dubious - may not be right
|
||||||
:PROPERTY-CONDITION (generate-property-condition tree)
|
;; :PROPERTY-CONDITION (generate-property-condition tree)
|
||||||
:QUALIFIER (generate (second tree))
|
;; :QUALIFIER (generate (second tree))
|
||||||
:RULE (generate-rule tree)
|
;; :RULE (generate-rule tree)
|
||||||
:SIMPLE-ACTION (generate-simple-action tree)
|
;; :SIMPLE-ACTION (generate-simple-action tree)
|
||||||
:SYMBOL (keyword (second tree))
|
;; :SYMBOL (keyword (second tree))
|
||||||
:VALUE (generate (second tree))
|
;; :VALUE (generate (second tree))
|
||||||
(map generate tree))
|
;; (map generate tree))
|
||||||
tree))
|
;; tree))
|
||||||
|
|
||||||
|
|
||||||
(defn simplify-qualifier
|
;; (defn simplify-qualifier
|
||||||
"Given that this `tree` fragment represents a qualifier, what
|
;; "Given that this `tree` fragment represents a qualifier, what
|
||||||
qualifier is that?"
|
;; qualifier is that?"
|
||||||
[tree]
|
;; [tree]
|
||||||
(cond
|
;; (cond
|
||||||
(empty? tree) nil
|
;; (empty? tree) nil
|
||||||
(and (coll? tree)
|
;; (and (coll? tree)
|
||||||
(member? (first tree) '(:EQUIVALENCE :COMPARATIVE))) tree
|
;; (member? (first tree) '(:EQUIVALENCE :COMPARATIVE))) tree
|
||||||
(coll? (first tree)) (or (simplify-qualifier (first tree))
|
;; (coll? (first tree)) (or (simplify-qualifier (first tree))
|
||||||
(simplify-qualifier (rest tree)))
|
;; (simplify-qualifier (rest tree)))
|
||||||
(coll? tree) (simplify-qualifier (rest tree))
|
;; (coll? tree) (simplify-qualifier (rest tree))
|
||||||
true tree))
|
;; true tree))
|
||||||
|
|
||||||
(defn simplify-second-of-two
|
;; (defn simplify-second-of-two
|
||||||
"There are a number of possible simplifications such that if the `tree` has
|
;; "There are a number of possible simplifications such that if the `tree` has
|
||||||
only two elements, the second is semantically sufficient."
|
;; only two elements, the second is semantically sufficient."
|
||||||
[tree]
|
;; [tree]
|
||||||
(if (= (count tree) 2) (simplify (nth tree 1)) tree))
|
;; (if (= (count tree) 2) (simplify (nth tree 1)) tree))
|
||||||
|
|
||||||
|
|
||||||
(defn rule?
|
;; (defn rule?
|
||||||
"Return true if the argument appears to be a parsed rule tree, else false."
|
;; "Return true if the argument appears to be a parsed rule tree, else false."
|
||||||
[maybe-rule]
|
;; [maybe-rule]
|
||||||
(and (coll? maybe-rule) (= (first maybe-rule) :RULE)))
|
;; (and (coll? maybe-rule) (= (first maybe-rule) :RULE)))
|
||||||
|
|
||||||
(defn simplify
|
;; (defn simplify
|
||||||
"Simplify/canonicalise this `tree`. Opportunistically replace complex fragments with
|
;; "Simplify/canonicalise this `tree`. Opportunistically replace complex fragments with
|
||||||
semantically identical simpler fragments"
|
;; semantically identical simpler fragments"
|
||||||
[tree]
|
;; [tree]
|
||||||
(if
|
;; (if
|
||||||
(coll? tree)
|
;; (coll? tree)
|
||||||
(case (first tree)
|
;; (case (first tree)
|
||||||
:ACTION (simplify-second-of-two tree)
|
;; :ACTION (simplify-second-of-two tree)
|
||||||
:ACTIONS (simplify-second-of-two tree)
|
;; :ACTIONS (simplify-second-of-two tree)
|
||||||
:COMPARATIVE (simplify-second-of-two tree)
|
;; :COMPARATIVE (simplify-second-of-two tree)
|
||||||
:CONDITION (simplify-second-of-two tree)
|
;; :CONDITION (simplify-second-of-two tree)
|
||||||
:CONDITIONS (simplify-second-of-two tree)
|
;; :CONDITIONS (simplify-second-of-two tree)
|
||||||
:EXPRESSION (simplify-second-of-two tree)
|
;; :EXPRESSION (simplify-second-of-two tree)
|
||||||
;; :QUANTIFIER (simplify-second-of-two tree)
|
;; ;; :QUANTIFIER (simplify-second-of-two tree)
|
||||||
:NOT nil
|
;; :NOT nil
|
||||||
:PROPERTY (simplify-second-of-two tree)
|
;; :PROPERTY (simplify-second-of-two tree)
|
||||||
:SPACE nil
|
;; :SPACE nil
|
||||||
:THEN nil
|
;; :THEN nil
|
||||||
;; :QUALIFIER (simplify-qualifier tree)
|
;; ;; :QUALIFIER (simplify-qualifier tree)
|
||||||
:VALUE (simplify-second-of-two tree)
|
;; :VALUE (simplify-second-of-two tree)
|
||||||
(remove nil? (map simplify tree)))
|
;; (remove nil? (map simplify tree)))
|
||||||
tree))
|
;; tree))
|
||||||
|
|
||||||
(def parse-rule
|
;; (def parse-rule
|
||||||
"Parse the argument, assumed to be a string in the correct syntax, and return a parse tree."
|
;; "Parse the argument, assumed to be a string in the correct syntax, and return a parse tree."
|
||||||
(insta/parser grammar))
|
;; (insta/parser grammar))
|
||||||
|
|
||||||
(defn explain-parse-error-reason
|
;; (defn explain-parse-error-reason
|
||||||
"Attempt to explain the reason for the parse error."
|
;; "Attempt to explain the reason for the parse error."
|
||||||
[reason]
|
;; [reason]
|
||||||
(str "Expecting one of (" (apply str (map #(str (:expecting %) " ") (first reason))) ")"))
|
;; (str "Expecting one of (" (apply str (map #(str (:expecting %) " ") (first reason))) ")"))
|
||||||
|
|
||||||
(defn throw-parse-exception
|
;; (defn throw-parse-exception
|
||||||
"Construct a helpful error message from this `parser-error`, and throw an exception with that message."
|
;; "Construct a helpful error message from this `parser-error`, and throw an exception with that message."
|
||||||
[parser-error]
|
;; [parser-error]
|
||||||
(assert (coll? parser-error) "Expected a paser error structure?")
|
;; (assert (coll? parser-error) "Expected a paser error structure?")
|
||||||
(let
|
;; (let
|
||||||
[
|
;; [
|
||||||
;; the error structure is a list, such that each element is a list of two items, and
|
;; ;; 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
|
;; ;; 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)
|
;; error-map (reduce (fn [map item](merge map {(first item)(rest item)})) {} parser-error)
|
||||||
text (first (:text error-map))
|
;; text (first (:text error-map))
|
||||||
reason (explain-parse-error-reason (:reason error-map))
|
;; reason (explain-parse-error-reason (:reason error-map))
|
||||||
;; rules have only one line, by definition; we're interested in the column
|
;; ;; rules have only one line, by definition; we're interested in the column
|
||||||
column (if (:column error-map)(first (:column error-map)) 0)
|
;; column (if (:column error-map)(first (:column error-map)) 0)
|
||||||
;; create a cursor to point to that column
|
;; ;; create a cursor to point to that column
|
||||||
cursor (apply str (reverse (conj (repeat column " ") "^")))
|
;; cursor (apply str (reverse (conj (repeat column " ") "^")))
|
||||||
message (format bad-parse-error text cursor reason)
|
;; message (format bad-parse-error text cursor reason)
|
||||||
]
|
;; ]
|
||||||
(throw (Exception. message))))
|
;; (throw (Exception. message))))
|
||||||
|
|
||||||
(defn compile-rule
|
;; (defn compile-rule
|
||||||
"Compile this `rule`, assumed to be a string with appropriate syntax, into a function of two arguments,
|
;; "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."
|
;; a `cell` and a `world`, having the same semantics."
|
||||||
[rule]
|
;; [rule]
|
||||||
(assert (string? rule))
|
;; (assert (string? rule))
|
||||||
(let [tree (simplify (parse-rule rule))]
|
;; (let [tree (simplify (parse-rule rule))]
|
||||||
(if (rule? tree) (eval (generate tree))
|
;; (if (rule? tree) (eval (generate tree))
|
||||||
(throw-parse-exception tree))))
|
;; (throw-parse-exception tree))))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue