Compare commits
	
		
			1 commit
		
	
	
		
			master
			...
			beforetheb
		
	
	| Author | SHA1 | Date | |
|---|---|---|---|
|  | 0716b517cb | 
|  | @ -16,7 +16,8 @@ | |||
|                  [secretary "1.2.3"] | ||||
|                  [environ "1.0.2"] | ||||
|                  [prismatic/dommy "1.1.0"] | ||||
|                  [immoh/dommy.template "0.2.0"]] | ||||
|                  [immoh/dommy.template "0.2.0"] | ||||
|                  [com.lucasbradstreet/instaparse-cljs "1.4.1.0"]] | ||||
| 
 | ||||
|   :plugins [[lein-cljsbuild "1.1.1"] | ||||
|             [lein-environ "1.0.1"]] | ||||
|  |  | |||
|  | @ -1,4 +1,5 @@ | |||
| (ns ^:figwheel-always mw3.core | ||||
|   (:use mw3.utils) | ||||
|   (:use-macros [dommy.template :only [node deftemplate]]) | ||||
|   (:require-macros [cljs.core.async.macros :refer [go]]) | ||||
|   (:require | ||||
|  |  | |||
							
								
								
									
										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