Added and changed bindings and added random and solid tiles

roguelike.cabal

@@ -29,4 +29,5 @@ executable roguelike
                        matrix,
                        unordered-containers,
                        microlens-th,
-                       microlens
+                       microlens,
+                       random

src/Action.hs

@@ -12,11 +12,15 @@ data Action = Walk Direction
 
 bindings :: [(Event, Action)]
 bindings =
-  [ (EvKey KUp         [], Walk N)
+  [ (EvKey (KChar 'k')  [], Walk N)
-  , (EvKey KDown       [], Walk S)
+  , (EvKey (KChar 'j')  [], Walk S)
-  , (EvKey KLeft       [], Walk W)
+  , (EvKey (KChar 'h')  [], Walk W)
-  , (EvKey KRight      [], Walk E)
+  , (EvKey (KChar 'l')  [], Walk E)
-  , (EvKey (KChar 'q') [], ExitGame)
+  , (EvKey (KChar 'y')  [], Walk NW)
+  , (EvKey (KChar 'u')  [], Walk NE)
+  , (EvKey (KChar 'b')  [], Walk SW)
+  , (EvKey (KChar 'n')  [], Walk SE)
+  , (EvKey (KChar 'q')  [], ExitGame)
   ]
 
 eventToAction :: Event -> Action

src/Direction.hs

@@ -1,3 +1,3 @@
 module Direction where
 
-data Direction = N | S | W | E
+data Direction = N | S | W | E | NW | NE | SW | SE

src/Dungeon.hs

@@ -1,6 +1,7 @@
 module Dungeon where
 
 import Data.Matrix
+import System.Random
 
 data Cell = Solid | Empty
 
@@ -13,8 +14,12 @@ newtype Dungeon = Dungeon (Matrix Cell)
 instance Show Dungeon where
   show (Dungeon m) = unlines . map (concatMap show) $ toLists m
 
-makeDungeon :: Int -> Int -> Dungeon
+makeDungeon :: (RandomGen r) => r -> Int -> Int -> Dungeon
-makeDungeon w h = Dungeon $ matrix h w $ const Empty
+makeDungeon gen w h = Dungeon $ Data.Matrix.fromList h w (randomCells gen)
+  where randomCells g = let (c,nGen) = randomR (0 :: Int,1 :: Int) g
+                        in case c of 0 -> Solid : randomCells nGen
+                                     1 -> Empty : randomCells nGen
+
 
 dungeonToLists :: Dungeon -> [[Cell]]
 dungeonToLists (Dungeon m) = toLists m

src/Game.hs

@@ -2,6 +2,7 @@
 
 module Game where
 
+import System.Random
 import Lens.Micro.TH
 import Lens.Micro
 
@@ -17,13 +18,17 @@ data Game = Game
 
 makeLenses ''Game
 
-newGame :: Game
+newGame :: (RandomGen r) => r -> Game
-newGame = Game (makeDungeon 30 10) (Player 0 0)
+newGame gen = Game (makeDungeon gen 30 10) (Player (0,0))
 
 runAction :: Action -> Game -> Maybe Game
-runAction (Walk N) game = Just $ game & player . y %~ (1 `subtract`)
+runAction (Walk N) game = Just $ game & player . pos . _2 -~ 1
-runAction (Walk S) game = Just $ game & player . y %~ (+1)
+runAction (Walk S) game = Just $ game & player . pos . _2 +~ 1
-runAction (Walk W) game = Just $ game & player . x %~ (1 `subtract`)
+runAction (Walk W) game = Just $ game & player . pos . _1 -~ 1
-runAction (Walk E) game = Just $ game & player . x %~ (+1)
+runAction (Walk E) game = Just $ game & player . pos . _1 +~ 1
+runAction (Walk NW) game = Just $ game & player . pos . both -~ 1
+runAction (Walk NE) game = Just $ game & player . pos %~ (\(x,y) -> (x+1, y-1))
+runAction (Walk SW) game = Just $ game & player . pos %~ (\(x,y) -> (x-1, y+1))
+runAction (Walk SE) game = Just $ game & player . pos . both +~ 1
 runAction None g = Just g
 runAction ExitGame _ = Nothing

src/Main.hs

@@ -1,6 +1,7 @@
 module Main where
 
 import Graphics.Vty
+import System.Random
 
 import Game
 import Rendering
@@ -10,7 +11,8 @@ main :: IO ()
 main = do
     cfg <- standardIOConfig
     vty <- mkVty cfg
-    loop vty newGame
+    gen <- getStdGen
+    loop vty $ newGame gen
     shutdown vty
     where loop vty game = do
             update vty $ renderGame game

src/Player.hs

@@ -5,8 +5,7 @@ module Player where
 import Lens.Micro.TH (makeLenses)
 
 data Player = Player
-  { _x :: Int
+  { _pos :: (Int, Int)
-  , _y :: Int
   }
 
 makeLenses ''Player

src/Rendering.hs

@@ -17,6 +17,6 @@ dungeonToImg :: Dungeon -> Image
 dungeonToImg = vertCat . map (string defAttr . concatMap show) . dungeonToLists
 
 playerToImg :: Player -> Image
-playerToImg p = translateX px . translateY py $ char defAttr '@'
+playerToImg p = (translateX px . translateY py $ char defAttr '@') <|> string defAttr ("                      (" ++ show px ++ "," ++ show py ++ ")")
-  where px = p ^. x
+  where px = p ^. pos . _1
-        py = p ^. y
+        py = p ^. pos . _2