001  (ns ^{:doc "Generate Clojure source from simplified parse trees."
002        :author "Simon Brooke"}
003   mw-parser.generate
004    (:require [clojure.pprint :refer [pprint]]
005              [clojure.tools.trace :refer [deftrace]]
006              [mw-parser.utils :refer [assert-type TODO]]
007              [mw-parser.errors :as pe]))
008  
009  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
010  ;;
011  ;; This program is free software; you can redistribute it and/or
012  ;; modify it under the terms of the GNU General Public License
013  ;; as published by the Free Software Foundation; either version 2
014  ;; of the License, or (at your option) any later version.
015  ;;
016  ;; This program is distributed in the hope that it will be useful,
017  ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
018  ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
019  ;; GNU General Public License for more details.
020  ;;
021  ;; You should have received a copy of the GNU General Public License
022  ;; along with this program; if not, write to the Free Software
023  ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
024  ;; USA.
025  ;;
026  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
027  
028  (declare generate generate-action)
029  
030  (defn generate-rule
031    "From this `tree`, assumed to be a syntactically correct rule specification,
032    generate and return the appropriate rule as a function of two arguments."
033    [tree]
034    (assert-type tree :RULE)
035    (vary-meta
036     (list 'fn ['cell 'world] (list 'when (generate (nth tree 2)) (generate (nth tree 3))))
037     merge
038     {:rule-type
039      :production}))
040  
041  (defn generate-conditions
042    "From this `tree`, assumed to be a syntactically correct conditions clause,
043    generate and return the appropriate clojure fragment."
044    [tree]
045    (assert-type tree :CONDITIONS)
046    (generate (second tree)))
047  
048  (defn generate-condition
049    "From this `tree`, assumed to be a syntactically correct condition clause,
050    generate and return the appropriate clojure fragment."
051    [tree]
052    (assert-type tree :CONDITION)
053    (generate (second tree)))
054  
055  (defn generate-conjunct-condition
056    "From this `tree`, assumed to be a syntactically conjunct correct condition clause,
057    generate and return the appropriate clojure fragment."
058    [tree]
059    (assert-type tree :CONJUNCT-CONDITION)
060    (cons 'and (map generate (rest tree))))
061  
062  (defn generate-disjunct-condition
063    "From this `tree`, assumed to be a syntactically correct disjunct condition clause,
064    generate and return the appropriate clojure fragment."
065    [tree]
066    (assert-type tree :DISJUNCT-CONDITION)
067    (cons 'or (map generate (rest tree))))
068  
069  (defn generate-ranged-property-condition
070    "From this `tree`, assumed to be a syntactically property condition clause for
071    this `property` where the `expression` is a numeric range, generate and return
072    the appropriate clojure fragment."
073    [tree property expression]
074    (assert-type tree :PROPERTY-CONDITION)
075    (assert-type (nth tree 3) :RANGE-EXPRESSION)
076    (let [l1 (generate (nth expression 2))
077          l2 (generate (nth expression 4))
078          pv (list property 'cell)]
079      (list 'let ['lower (list 'min l1 l2)
080                  'upper (list 'max l1 l2)]
081            (list 'and (list '>= pv 'lower) (list '<= pv 'upper)))))
082  
083  (defn generate-disjunct-property-condition
084    "From this `tree`, assumed to be a syntactically property condition clause
085    where the expression is a a disjunction, generate and return
086    the appropriate clojure fragment.
087    TODO: this is definitely still wrong!"
088    ([tree]
089     (let [property (generate (second tree))
090           qualifier (generate (nth tree 2))
091           expression (generate (nth tree 3))]
092       (generate-disjunct-property-condition tree property qualifier expression)))
093    ([_tree property qualifier expression]
094     (let [e (list expression (list property 'cell))]
095       (if (= qualifier '=) e
096           (list 'not e)))))
097  
098  (defn generate-property-condition
099    "From this `tree`, assumed to be a syntactically property condition clause,
100    generate and return the appropriate clojure fragment."
101    ([tree]
102     (assert-type tree :PROPERTY-CONDITION)
103     (if
104      (and (= (count tree) 2) (= (first (second tree)) :SYMBOL))
105       ;; it's a shorthand for 'state equal to symbol'. This should probably have
106       ;; been handled in simplify...
107       (generate-property-condition
108        (list
109         :PROPERTY-CONDITION
110         '(:SYMBOL "state")
111         '(:QUALIFIER (:EQUIVALENCE (:EQUAL "equal to")))
112         (second tree)))
113       ;; otherwise...
114       (generate-property-condition tree (first (nth tree 3)))))
115    ([tree expression-type]
116     (assert-type tree :PROPERTY-CONDITION)
117     (let [property (generate (second tree))
118           qualifier (generate (nth tree 2))
119           e (generate (nth tree 3))
120           expression (cond
121                        (and (not (= qualifier '=)) (keyword? e)) (list 'or (list e 'cell) e)
122                        (and (not (= qualifier 'not=)) (keyword? e)) (list 'or (list e 'cell) e)
123                        :else e)]
124       (case expression-type
125         :DISJUNCT-EXPRESSION (generate-disjunct-property-condition tree property qualifier expression)
126         :RANGE-EXPRESSION (generate-ranged-property-condition tree property expression)
127         (list qualifier (list property 'cell) expression)))))
128  
129  (defn generate-qualifier
130    "From this `tree`, assumed to be a syntactically correct qualifier,
131    generate and return the appropriate clojure fragment."
132    [tree]
133    (if
134     (= (count tree) 2)
135      (generate (second tree))
136      ;; else
137      (generate (nth tree 2))))
138  
139  (defn generate-simple-action
140    "From this `tree`, assumed to be a syntactically correct simple action,
141    generate and return the appropriate clojure fragment."
142    ([tree]
143     (assert-type tree :SIMPLE-ACTION)
144     (generate-simple-action tree []))
145    ([tree others]
146     (assert-type tree :SIMPLE-ACTION)
147     (let [property (generate (second tree))
148           expression (generate (nth tree 3))]
149       (if (or (= property :x) (= property :y))
150         (throw (Exception. pe/reserved-properties-error))
151         (list 'merge
152               (if (empty? others) 'cell
153                 ;; else
154                   (generate others))
155               {property expression})))))
156  
157  (defn generate-probable-action
158    "From this `tree`, assumed to be a syntactically correct probable action,
159    generate and return the appropriate clojure fragment."
160    ([tree]
161     (assert-type tree :PROBABLE-ACTION)
162     (generate-probable-action tree []))
163    ([tree others]
164     (assert-type tree :PROBABLE-ACTION)
165     (let
166      [chances (generate (nth tree 1))
167       total (generate (nth tree 2))
168       action (generate-action (nth tree 3) others)]
169      ;; TODO: could almost certainly be done better with macro syntax
170       (list 'if
171             (list '< (list 'rand total) chances)
172             action))))
173  
174  (defn generate-action
175    "From this `tree`, assumed to be a syntactically correct action,
176    generate and return the appropriate clojure fragment."
177    [tree others]
178    (case (first tree)
179      :ACTIONS (generate-action (first tree) others)
180      :SIMPLE-ACTION (generate-simple-action tree others)
181      :PROBABLE-ACTION (generate-probable-action tree others)
182      (throw (Exception. (str "Not a known action type: " (first tree))))))
183  
184  (defn generate-multiple-actions
185    "From this `tree`, assumed to be one or more syntactically correct actions,
186    generate and return the appropriate clojure fragment."
187    [tree]
188    (assert-type tree :ACTIONS)
189    (generate-action (first (rest tree)) (second (rest tree))))
190  
191  (defn generate-disjunct-value
192    "Generate a disjunct value. Essentially what we need here is to generate a
193    flat list of values, since the `member` has already been taken care of."
194    [tree]
195    (assert-type tree :DISJUNCT-VALUE)
196    (if (= (count tree) 4)
197      (cons (generate (second tree)) (generate (nth tree 3)))
198      (list (generate (second tree)))))
199  
200  (defn generate-numeric-expression
201    "From this `tree`, assumed to be a syntactically correct numeric expression,
202    generate and return the appropriate clojure fragment."
203    [tree]
204    (assert-type tree :NUMERIC-EXPRESSION)
205    (case (count tree)
206      4 (let [[p operator expression] (rest tree)
207              property (if (number? p) p (list p 'cell))]
208          (list (generate operator) (generate property) (generate expression)))
209      (case (first (second tree))
210        :SYMBOL (list (keyword (second (second tree))) 'cell)
211        (generate (second tree)))))
212  
213  (defn generate-neighbours-condition
214    "Generate code for a condition which refers to neighbours."
215    ([tree]
216     (assert-type tree :NEIGHBOURS-CONDITION)
217     (case (first (second tree))
218       :NUMBER (read-string (second (second tree)))
219       :QUANTIFIER (generate-neighbours-condition tree (first (second (second tree))))
220       :QUALIFIER (cons (generate (second tree)) (rest (generate (nth tree 2))))))
221    ([tree quantifier-type]
222     (let [quantifier (second tree)
223           pc (generate (nth tree 4))]
224       (case quantifier-type
225         :NUMBER (generate-neighbours-condition '= (read-string (second (second quantifier))) pc 1)
226         :SOME (generate-neighbours-condition '> 0 pc 1)
227         :MORE (let [value (generate (nth quantifier 3))]
228                 (generate-neighbours-condition '> value pc 1))
229         :LESS (let [value (generate (nth quantifier 3))]
230                 (generate-neighbours-condition '< value pc 1)))))
231    ([comp1 quantity property-condition distance]
232     (list comp1
233           (list 'count
234                 (list 'remove 'false?
235                       (list 'map (list 'fn ['cell] property-condition)
236                             (list 'mw-engine.utils/get-neighbours 'world 'cell distance)))) quantity))
237    ([comp1 quantity property-condition]
238     (generate-neighbours-condition comp1 quantity property-condition 1)))
239  
240  (defn generate-within-condition
241    "Generate code for a condition which refers to neighbours within a specified distance.
242    NOTE THAT there's clearly masses of commonality between this and
243    `generate-neighbours-condition`, and that some refactoring is almost certainly
244    desirable. It may be that it's better to simplify a `NEIGHBOURS-CONDITION`
245    into a `WITHIN-CONDITION` in the simplification stage."
246    ([tree]
247     (assert-type tree :WITHIN-CONDITION)
248     (case (first (second tree))
249       :QUANTIFIER (generate-within-condition tree (first (second (second tree))))
250       :QUALIFIER (TODO "qualified within... help!")))
251    ([tree quantifier-type]
252     (let [quantifier (second tree)
253           distance (generate (nth tree 4))
254           pc (generate (nth tree 6))]
255       (case quantifier-type
256         :NUMBER (generate-neighbours-condition '= (read-string (second (second quantifier))) pc distance)
257         :SOME (generate-neighbours-condition '> 0 pc distance)
258         :MORE (let [value (generate (nth quantifier 3))]
259                 (generate-neighbours-condition '> value pc distance))
260         :LESS (let [value (generate (nth quantifier 3))]
261                 (generate-neighbours-condition '< value pc distance))))))
262  
263  (defn- generate-disjunct-expression
264    [tree]
265    (assert-type tree :DISJUNCT-EXPRESSION)
266    (try
267      (set (map generate (rest tree)))
268      (catch Exception x
269        (throw
270         (ex-info
271          "Failed to compile :DISJUNCT-EXPRESSION"
272          {:tree tree}
273          x)))))
274  
275  ;;; Flow rules. A flow rule DOES NOT return a modified world; instead, it 
276  ;;; returns a PLAN to modify the world, in the form of a sequence of `flows`.
277  ;;; It is only when the plan is executed that the world is modified.
278  ;;;
279  ;;; so we're looking at something like
280  ;;; (fn [cell world])
281  ;;;    (if (= (:state cell) (or (:house cell) :house))
282  
283  (defn generate-flow
284    [tree]
285    (assert-type tree :FLOW-RULE))
286  
287  ;;; Top level; only function anything outside this file (except tests) should 
288  ;;; really call.
289  
290  (defn generate
291    "Generate code for this (fragment of a) parse tree"
292    [tree]
293    (if
294     (coll? tree)
295      (case (first tree)
296        :ACTIONS (generate-multiple-actions tree)
297        :COMPARATIVE (generate (second tree))
298        :COMPARATIVE-QUALIFIER (generate (second tree))
299        :CONDITION (generate-condition tree)
300        :CONDITIONS (generate-conditions tree)
301        :CONJUNCT-CONDITION (generate-conjunct-condition tree)
302        :DISJUNCT-CONDITION (generate-disjunct-condition tree)
303        :DISJUNCT-EXPRESSION (generate-disjunct-expression tree)
304        :DISJUNCT-VALUE (generate-disjunct-value tree)
305        :EQUIVALENCE '=
306        :EXPRESSION (generate (second tree))
307        :FLOW-RULE (generate-flow tree)
308        :LESS '<
309        :MORE '>
310        :NEGATED-QUALIFIER (case (generate (second tree))
311                             = 'not=
312                             > '<
313                             < '>)
314        :NEIGHBOURS-CONDITION (generate-neighbours-condition tree)
315        :NUMERIC-EXPRESSION (generate-numeric-expression tree)
316        :NUMBER (read-string (second tree))
317        :OPERATOR (symbol (second tree))
318        :PROBABLE-ACTION (generate-probable-action tree)
319        :PROPERTY (list (generate (second tree)) 'cell) ;; dubious - may not be right
320        :PROPERTY-CONDITION (generate-property-condition tree)
321        :QUALIFIER (generate-qualifier tree)
322        :RULE (generate-rule tree)
323        :SIMPLE-ACTION (generate-simple-action tree)
324        :SYMBOL (keyword (second tree))
325        :VALUE (generate (second tree))
326        :WITHIN-CONDITION (generate-within-condition tree)
327        (map generate tree))
328      tree))