wat

src/caves/core.clj

@@ -18,8 +18,7 @@
         (recur (process-input (dissoc game :input) input))))))
 
 (defn new-game []
-  (assoc (->Game nil [(->UI :start)] nil)
-         :location [40 20]))
+  (->Game nil [(->UI :start)] nil))
 
 (defn main
   ([screen-type] (main screen-type false))

src/caves/entities/aspects/digger.clj

@@ -0,0 +1,7 @@
+(ns caves.entities.aspects.digger)
+
+(defprotocol Digger
+  (dig [this world dx dy]
+       "Dig a location.")
+  (can-dig? [this world dx dy]
+            "Return whether the entity can dig the new location."))

src/caves/entities/aspects/mobile.clj

@@ -0,0 +1,9 @@
+(ns caves.entities.aspects.mobile)
+
+
+(defprotocol Mobile
+  (move [this world dx dy]
+        "Move this entity to a new location.")
+  (can-move? [this world dx dy]
+             "Return whether the entity can move to the new location."))
+

src/caves/entities/core.clj

@@ -0,0 +1,7 @@
+(ns caves.entities.core)
+
+
+(defprotocol Entity
+  (tick [this world]
+        "Update the world to handle the passing of a tick for this entity."))
+

src/caves/entities/player.clj

@@ -0,0 +1,64 @@
+(ns caves.entities.player
+  (:use [caves.entities.core :only [Entity]]
+        [caves.entities.aspects.mobile :only [Mobile move can-move?]]
+        [caves.entities.aspects.digger :only [Digger dig can-dig?]]
+        [caves.world :only [find-empty-tile get-tile-kind set-tile-floor]]))
+
+
+(defrecord Player [id loc])
+
+(defn offset-coords [[x y] dx dy]
+  [(+ x dx) (+ y dy)])
+
+(defn check-tile
+  "Take a player and an offset, and check that the tile at the destination
+  passes the given predicate."
+  [player world dx dy pred]
+  (let [[x y] (offset-coords (:loc player) dx dy)
+        dest-tile (get-tile-kind world x y)]
+    (pred dest-tile)))
+
+(defn dir-to-offset [dir]
+  (case dir
+    :w  [-1 0]
+    :e  [1 0]
+    :n  [0 -1]
+    :s  [0 1]
+    :nw [-1 -1]
+    :ne [1 -1]
+    :sw [-1 1]
+    :se [1 1]))
+
+
+(extend-type Player Entity
+  (tick [this world]
+    world))
+
+(extend-type Player Mobile
+  (move [this world dx dy]
+    (if (can-move? this world dx dy)
+      (update-in world [:player :loc] offset-coords dx dy)
+      world))
+  (can-move? [this world dx dy]
+    (check-tile this world dx dy #{:floor})))
+
+(extend-type Player Digger
+  (dig [this world dx dy]
+    (if (can-dig? this world dx dy)
+      (let [[tx ty] (offset-coords (:loc this) dx dy)]
+        (set-tile-floor world tx ty))
+      world))
+  (can-dig? [this world dx dy]
+    (check-tile this world dx dy #{:wall})))
+
+
+(defn make-player [world]
+  (->Player :player (find-empty-tile world)))
+
+(defn move-player [world direction]
+  (let [player (:player world)
+        [dx dy] (dir-to-offset direction)]
+    (cond
+      (can-move? player world dx dy) (move player world dx dy)
+      (can-dig? player world dx dy) (dig player world dx dy)
+      :else world)))

src/caves/ui/drawing.clj

@@ -34,9 +34,8 @@
   (s/put-string screen 0 1 "Press escape to exit, anything else to restart."))
 
 
-(defn get-viewport-coords [game vcols vrows]
-  (let [location (:location game)
-        [center-x center-y] location
+(defn get-viewport-coords [game player-location vcols vrows]
+  (let [[center-x center-y] player-location
 
         tiles (:tiles (:world game))
 
@@ -59,11 +58,19 @@
         start-y (- end-y vrows)]
     [start-x start-y end-x end-y]))
 
-(defn draw-crosshairs [screen vcols vrows]
-  (let [crosshair-x (int (/ vcols 2))
-          crosshair-y (int (/ vrows 2))]
-      (s/put-string screen crosshair-x crosshair-y "X" {:fg :red})
-      (s/move-cursor screen crosshair-x crosshair-y)))
+(defn draw-hud [screen game start-x start-y]
+  (let [hud-row (dec (second screen-size))
+        [x y] (get-in game [:world :player :loc])
+        info (str "loc: [" x "-" y "]")
+        info (str info " start: [" start-x " " start-y "]")
+        ]
+    (s/put-string screen 0 hud-row info)))
+
+(defn draw-player [screen start-x start-y [player-x player-y]]
+  (let [x (- player-x start-x)
+        y (- player-y start-y)]
+      (s/put-string screen x y "@" {:fg :white})
+      (s/move-cursor screen x y)))
 
 (defn draw-world [screen vrows vcols start-x start-y end-x end-y tiles]
   (doseq [[vrow-idx mrow-idx] (map vector
@@ -77,12 +84,14 @@
 (defmethod draw-ui :play [ui game screen]
   (let [world (:world game)
         tiles (:tiles world)
+        player-location (get-in world [:player :loc])
         [cols rows] screen-size
         vcols cols
         vrows (dec rows)
-        [start-x start-y end-x end-y] (get-viewport-coords game vcols vrows)]
+        [start-x start-y end-x end-y] (get-viewport-coords game player-location vcols vrows)]
     (draw-world screen vrows vcols start-x start-y end-x end-y tiles)
-    (draw-crosshairs screen vcols vrows)))
+    (draw-player screen start-x start-y player-location)
+    (draw-hud screen game start-x start-y)))
 
 
 (defn draw-game [game screen]

src/caves/ui/input.clj

@@ -1,6 +1,7 @@
 (ns caves.ui.input
   (:use [caves.world :only [random-world smooth-world]]
-        [caves.ui.core :only [->UI]])
+        [caves.ui.core :only [->UI]]
+        [caves.entities.player :only [move-player make-player]])
   (:require [lanterna.screen :as s]))
 
 
@@ -9,31 +10,27 @@
     (:kind (last (:uis game)))))
 
 (defmethod process-input :start [game input]
-  (-> game
-    (assoc :world (random-world))
-    (assoc :uis [(->UI :play)])))
+  (let [fresh-world (random-world)]
+    (-> game
+      (assoc :world fresh-world)
+      (assoc-in [:world :player] (make-player fresh-world))
+      (assoc :uis [(->UI :play)]))))
 
 
-(defn move [[x y] [dx dy]]
-  [(+ x dx) (+ y dy)])
-
 (defmethod process-input :play [game input]
   (case input
     :enter     (assoc game :uis [(->UI :win)])
     :backspace (assoc game :uis [(->UI :lose)])
     \q         (assoc game :uis [])
 
-    \s (update-in game [:world] smooth-world)
-
-    \h (update-in game [:location] move [-1 0])
-    \j (update-in game [:location] move [0 1])
-    \k (update-in game [:location] move [0 -1])
-    \l (update-in game [:location] move [1 0])
-
-    \H (update-in game [:location] move [-5 0])
-    \J (update-in game [:location] move [0 5])
-    \K (update-in game [:location] move [0 -5])
-    \L (update-in game [:location] move [5 0])
+    \h (update-in game [:world] move-player :w)
+    \j (update-in game [:world] move-player :s)
+    \k (update-in game [:world] move-player :n)
+    \l (update-in game [:world] move-player :e)
+    \y (update-in game [:world] move-player :nw)
+    \u (update-in game [:world] move-player :ne)
+    \b (update-in game [:world] move-player :sw)
+    \n (update-in game [:world] move-player :se)
 
     game))
 

src/caves/world.clj

@@ -16,6 +16,9 @@
 (defn get-tile [tiles x y]
   (get-in tiles [y x] (:bound tiles)))
 
+(defn set-tile-floor [world x y]
+  (assoc-in world [:tiles y x] (:floor tiles)))
+
 
 ; Debugging -------------------------------------------------------------------
 (defn print-row [row]
@@ -70,6 +73,23 @@
 
 (defn random-world []
   (let [world (->World (random-tiles))
-        world (nth (iterate smooth-world world) 0)]
+        world (nth (iterate smooth-world world) 3)]
     world))
 
+
+; Querying a world ------------------------------------------------------------
+(defn random-coordinate []
+  (let [[cols rows] world-size]
+    [(rand-int cols) (rand-int rows)]))
+
+(defn find-empty-tile [world]
+  (loop [[x y] (random-coordinate)]
+    (let [{:keys [kind]} (get-tile (:tiles world) x y)]
+      (if (#{:floor} kind)
+        [x y]
+        (recur (random-coordinate))))))
+
+
+(defn get-tile-kind [world x y]
+  (:kind (get-tile (:tiles world) x y)))
+