This again doesn't compile, with the same error - can't take nth of symbol -
as previously, and again I don't know why.
This commit is contained in:
		
							parent
							
								
									e75a2bccf4
								
							
						
					
					
						commit
						0716b517cb
					
				|  | @ -16,7 +16,8 @@ | ||||||
|                  [secretary "1.2.3"] |                  [secretary "1.2.3"] | ||||||
|                  [environ "1.0.2"] |                  [environ "1.0.2"] | ||||||
|                  [prismatic/dommy "1.1.0"] |                  [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"] |   :plugins [[lein-cljsbuild "1.1.1"] | ||||||
|             [lein-environ "1.0.1"]] |             [lein-environ "1.0.1"]] | ||||||
|  |  | ||||||
|  | @ -1,4 +1,5 @@ | ||||||
| (ns ^:figwheel-always mw3.core | (ns ^:figwheel-always mw3.core | ||||||
|  |   (:use mw3.utils) | ||||||
|   (:use-macros [dommy.template :only [node deftemplate]]) |   (:use-macros [dommy.template :only [node deftemplate]]) | ||||||
|   (:require-macros [cljs.core.async.macros :refer [go]]) |   (:require-macros [cljs.core.async.macros :refer [go]]) | ||||||
|   (:require |   (:require | ||||||
|  |  | ||||||
							
								
								
									
										356
									
								
								src/cljs/mw3/parser.cljc
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										356
									
								
								src/cljs/mw3/parser.cljc
									
									
									
									
									
										Normal file
									
								
							|  | @ -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)))) | ||||||
							
								
								
									
										274
									
								
								src/cljs/mw3/utils.cljc
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										274
									
								
								src/cljs/mw3/utils.cljc
									
									
									
									
									
										Normal file
									
								
							|  | @ -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)) | ||||||
		Loading…
	
		Reference in a new issue