# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1342290769 14400
# Node ID 180b5b981d920e633a03be87cea348dc6dbfb88c
# Parent  b894c3ffe436500e84e6e49dd21ddaeb1f6f3812
use the black magic everywhere

diff -r b894c3ffe436 -r 180b5b981d92 src/caves/entities/aspects/attacker.clj
--- 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))))
 
diff -r b894c3ffe436 -r 180b5b981d92 src/caves/entities/aspects/destructible.clj
--- 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)))))
diff -r b894c3ffe436 -r 180b5b981d92 src/caves/entities/aspects/digger.clj
--- 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})))
diff -r b894c3ffe436 -r 180b5b981d92 src/caves/entities/aspects/mobile.clj
--- 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)]}
diff -r b894c3ffe436 -r 180b5b981d92 src/caves/entities/core.clj
--- 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)))
-
-
-  )
diff -r b894c3ffe436 -r 180b5b981d92 src/caves/entities/lichen.clj
--- 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)
diff -r b894c3ffe436 -r 180b5b981d92 src/caves/entities/player.clj
--- 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))
diff -r b894c3ffe436 -r 180b5b981d92 src/caves/world.clj
--- 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)))
+