--- a/src/caves/entities/aspects/attacker.clj Sat Jul 14 00:31:26 2012 -0400
+++ b/src/caves/entities/aspects/attacker.clj Sat Jul 14 14:32:49 2012 -0400
@@ -1,8 +1,11 @@
(ns caves.entities.aspects.attacker
- (:use [caves.entities.core :only [defaspect]]))
+ (:use [caves.entities.aspects.destructible :only [Destructible take-damage]]
+ [caves.entities.core :only [defaspect]]))
-(defprotocol Attacker
+(defaspect Attacker
(attack [this world target]
- "Attack the target."))
+ {:pre [(satisfies? Destructible target)]}
+ (let [damage 1]
+ (take-damage target world damage))))
--- a/src/caves/entities/aspects/destructible.clj Sat Jul 14 00:31:26 2012 -0400
+++ b/src/caves/entities/aspects/destructible.clj Sat Jul 14 14:32:49 2012 -0400
@@ -1,6 +1,10 @@
-(ns caves.entities.aspects.destructible)
+(ns caves.entities.aspects.destructible
+ (:use [caves.entities.core :only [defaspect]]))
-(defprotocol Destructible
- (take-damage [this world damage]
- "Take the given amount of damage and update the world appropriately."))
+(defaspect Destructible
+ (take-damage [{:keys [id] :as this} world damage]
+ (let [damaged-this (update-in this [:hp] - damage)]
+ (if-not (pos? (:hp damaged-this))
+ (update-in world [:entities] dissoc id)
+ (update-in world [:entities id] assoc damaged-this)))))
--- a/src/caves/entities/aspects/digger.clj Sat Jul 14 00:31:26 2012 -0400
+++ b/src/caves/entities/aspects/digger.clj Sat Jul 14 14:32:49 2012 -0400
@@ -1,8 +1,11 @@
-(ns caves.entities.aspects.digger)
+(ns caves.entities.aspects.digger
+ (:use [caves.entities.core :only [defaspect]]
+ [caves.world :only [check-tile set-tile-floor]]))
-(defprotocol Digger
- (dig [this world target]
- "Dig a location.")
- (can-dig? [this world target]
- "Return whether the entity can dig the new location."))
+(defaspect Digger
+ (dig [this world dest]
+ {:pre [(can-dig? this world dest)]}
+ (set-tile-floor world dest))
+ (can-dig? [this world dest]
+ (check-tile world dest #{:wall})))
--- a/src/caves/entities/aspects/mobile.clj Sat Jul 14 00:31:26 2012 -0400
+++ b/src/caves/entities/aspects/mobile.clj Sat Jul 14 14:32:49 2012 -0400
@@ -3,7 +3,6 @@
[caves.world :only [is-empty?]]))
-
(defaspect Mobile
(move [this world dest]
{:pre [(can-move? this world dest)]}
--- a/src/caves/entities/core.clj Sat Jul 14 00:31:26 2012 -0400
+++ b/src/caves/entities/core.clj Sat Jul 14 14:32:49 2012 -0400
@@ -15,16 +15,63 @@
id)))
-(defn make-fnmap [fns]
+(defn make-fnmap
+ "Make a function map out of the given sequence of fnspecs.
+
+ A function map is a map of functions that you'd pass to extend. For example,
+ this sequence of fnspecs:
+
+ ((foo [a] (println a)
+ (bar [a b] (+ a b)))
+
+ Would be turned into this fnmap:
+
+ {:foo (fn [a] (println a))
+ :bar (fn [a b] (+ a b))}
+
+ "
+ [fns]
(into {} (for [[label fntail] (map (juxt first rest) fns)]
[(keyword label)
`(fn ~@fntail)])))
-(defn make-fnheads [fns]
+(defn make-fnheads
+ "Make a sequence of fnheads of of the given sequence of fnspecs.
+
+ A fnhead is a sequence of (name args) like you'd pass to defprotocol. For
+ example, this sequence of fnspecs:
+
+ ((foo [a] (println a))
+ (bar [a b] (+ a b)))
+
+ Would be turned into this sequence of fnheads:
+
+ ((foo [a])
+ (bar [a b]))
+
+ "
+ [fns]
(map #(take 2 %) fns))
-(defmacro defaspect [label & fns]
+(defmacro defaspect
+ "Define an aspect with the given functions and default implementations.
+
+ For example:
+
+ (defaspect Fooable
+ (foo [this world]
+ (println \"Foo!\"))
+ (can-foo? [this world]
+ (contains? world :foo)))
+
+ This will define a Clojure protocol Fooable with the given functions as usual.
+ It will also attack the function implementations as metadata, which is used by
+ the add-aspect macro. Aside from the metadata, Fooable is a normal Clojure
+ protocol.
+
+ "
+ [label & fns]
(let [fnmap (make-fnmap fns)
fnheads (make-fnheads fns)]
`(do
@@ -33,29 +80,31 @@
(def ~label
(with-meta ~label {:defaults ~fnmap})))))
-(defmacro add-aspect [entity aspect & fns]
+(defmacro add-aspect
+ "Add an aspect to an entity type.
+
+ This is similar to extend-type, with two differences:
+
+ * It must be used on a protocol defined with defaspect
+ * It will use the aspect's default function implementation for any functions
+ not given.
+
+ This allows us to define common aspect functions (like can-move? and move for
+ Mobile) once and only once, while still allowing them to be overridden to
+ customize behavior.
+
+ For example:
+
+ (add-aspect Fooer Fooable
+ (foo [this world]
+ (println \"Bar!\")))
+
+ This will extend the type Fooer to implement the Fooable protocol. It will
+ use the default implementation of can-foo? that was defined in the addaspect
+ call, but overrides the implementation of foo to do something special.
+
+ "
+ [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/lichen.clj Sat Jul 14 00:31:26 2012 -0400
+++ b/src/caves/entities/lichen.clj Sat Jul 14 14:32:49 2012 -0400
@@ -1,5 +1,5 @@
(ns caves.entities.lichen
- (:use [caves.entities.core :only [Entity get-id]]
+ (:use [caves.entities.core :only [Entity get-id add-aspect]]
[caves.entities.aspects.destructible :only [Destructible take-damage]]
[caves.world :only [find-empty-neighbor]]))
@@ -25,9 +25,4 @@
(grow this world)
world)))
-(extend-type Lichen Destructible
- (take-damage [{:keys [id] :as this} world damage]
- (let [damaged-this (update-in this [:hp] - damage)]
- (if-not (pos? (:hp damaged-this))
- (update-in world [:entities] dissoc id)
- (update-in world [:entities id] assoc damaged-this)))))
+(add-aspect Lichen Destructible)
--- a/src/caves/entities/player.clj Sat Jul 14 00:31:26 2012 -0400
+++ b/src/caves/entities/player.clj Sat Jul 14 14:32:49 2012 -0400
@@ -3,39 +3,19 @@
[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]]
- [caves.entities.aspects.destructible :only [Destructible take-damage]]
[caves.coords :only [destination-coords]]
- [caves.world :only [is-empty? get-tile-kind set-tile-floor
- get-entity-at]]))
+ [caves.world :only [get-entity-at]]))
(defrecord Player [id glyph color location])
-(defn check-tile
- "Check that the tile at the destination passes the given predicate."
- [world dest pred]
- (pred (get-tile-kind world dest)))
-
-
(extend-type Player Entity
(tick [this world]
world))
(add-aspect Player Mobile)
-
-(extend-type Player Digger
- (dig [this world dest]
- {:pre [(can-dig? this world dest)]}
- (set-tile-floor world dest))
- (can-dig? [this world dest]
- (check-tile world dest #{:wall})))
-
-(extend-type Player Attacker
- (attack [this world target]
- {:pre [(satisfies? Destructible target)]}
- (let [damage 1]
- (take-damage target world damage))))
-
+(add-aspect Player Digger)
+(add-aspect Player Attacker)
(defn make-player [location]
(->Player :player "@" :white location))
--- a/src/caves/world.clj Sat Jul 14 00:31:26 2012 -0400
+++ b/src/caves/world.clj Sat Jul 14 14:32:49 2012 -0400
@@ -105,3 +105,9 @@
(when (seq candidates)
(rand-nth candidates))))
+
+(defn check-tile
+ "Check that the tile at the destination passes the given predicate."
+ [world dest pred]
+ (pred (get-tile-kind world dest)))
+