--- a/src/caves/entities/aspects/attacker.clj Fri Jul 13 23:52:13 2012 -0400
+++ b/src/caves/entities/aspects/attacker.clj Sat Jul 14 00:31:26 2012 -0400
@@ -1,4 +1,5 @@
-(ns caves.entities.aspects.attacker)
+(ns caves.entities.aspects.attacker
+ (:use [caves.entities.core :only [defaspect]]))
(defprotocol Attacker
--- a/src/caves/entities/aspects/mobile.clj Fri Jul 13 23:52:13 2012 -0400
+++ b/src/caves/entities/aspects/mobile.clj Sat Jul 14 00:31:26 2012 -0400
@@ -1,9 +1,13 @@
-(ns caves.entities.aspects.mobile)
+(ns caves.entities.aspects.mobile
+ (:use [caves.entities.core :only [defaspect]]
+ [caves.world :only [is-empty?]]))
+
-(defprotocol Mobile
+(defaspect Mobile
(move [this world dest]
- "Move this entity to a new location.")
+ {:pre [(can-move? this world dest)]}
+ (assoc-in world [:entities (:id this) :location] dest))
(can-move? [this world dest]
- "Return whether the entity can move to the new location."))
+ (is-empty? world dest)))
--- a/src/caves/entities/core.clj Fri Jul 13 23:52:13 2012 -0400
+++ b/src/caves/entities/core.clj Sat Jul 14 00:31:26 2012 -0400
@@ -13,3 +13,49 @@
(let [id @ids]
(alter ids inc)
id)))
+
+
+(defn make-fnmap [fns]
+ (into {} (for [[label fntail] (map (juxt first rest) fns)]
+ [(keyword label)
+ `(fn ~@fntail)])))
+
+(defn make-fnheads [fns]
+ (map #(take 2 %) fns))
+
+
+(defmacro defaspect [label & fns]
+ (let [fnmap (make-fnmap fns)
+ fnheads (make-fnheads fns)]
+ `(do
+ (defprotocol ~label
+ ~@fnheads)
+ (def ~label
+ (with-meta ~label {:defaults ~fnmap})))))
+
+(defmacro add-aspect [entity aspect & fns]
+ (let [fnmap (make-fnmap fns)]
+ `(extend ~entity ~aspect (merge (:defaults (meta ~aspect))
+ ~fnmap))))
+
+
+(comment
+
+ (macroexpand-1
+ '(defaspect Mobile
+ (move [world target]
+ (when (can-move? world target)
+ (println world)))
+ (can-move? [world target]
+ true)))
+
+ (macroexpand-1
+ '(add-aspect Player Mobile))
+
+ (macroexpand-1
+ '(add-aspect EE Mobile
+ (can-move? [world target]
+ true)))
+
+
+ )
--- a/src/caves/entities/player.clj Fri Jul 13 23:52:13 2012 -0400
+++ b/src/caves/entities/player.clj Sat Jul 14 00:31:26 2012 -0400
@@ -1,5 +1,5 @@
(ns caves.entities.player
- (:use [caves.entities.core :only [Entity]]
+ (:use [caves.entities.core :only [Entity add-aspect]]
[caves.entities.aspects.mobile :only [Mobile move can-move?]]
[caves.entities.aspects.digger :only [Digger dig can-dig?]]
[caves.entities.aspects.attacker :only [Attacker attack]]
@@ -21,12 +21,7 @@
(tick [this world]
world))
-(extend-type Player Mobile
- (move [this world dest]
- {:pre [(can-move? this world dest)]}
- (assoc-in world [:entities :player :location] dest))
- (can-move? [this world dest]
- (is-empty? world dest)))
+(add-aspect Player Mobile)
(extend-type Player Digger
(dig [this world dest]