@@ -4,37 +4,31 @@ module Main where
4import Graphics.Vty
4import Graphics.Vty
6import Data.Array
6import Data.Array
7−import qualified Data.ByteString as B
8import Data.Default (def)
7import Data.Default (def)
11import Control.Applicative
9import Control.Applicative
12−import Control.Lens hiding (Level)
13import Control.Monad
10import Control.Monad
14import Control.Monad.RWS
11import Control.Monad.RWS
15−import Control.Monad.Writer
18import System.Random
13import System.Random
20−data Dude = Dude
15+data Player = Player
21− { dudeX :: Int
16+ { playerCoord :: Coord
23 } deriving (Show,Eq)
17 } deriving (Show,Eq)
25data World = World
19data World = World
26− { dude :: Dude
20+ { player :: Player
27 , level :: Level
21 , level :: Level
29 deriving (Show,Eq)
23 deriving (Show,Eq)
31data Level = Level
25data Level = Level
32− { start :: (Int, Int)
26+ { levelStart :: Coord
33− , end :: (Int, Int)
27+ , levelEnd :: Coord
34− , geo :: Array (Int, Int) LevelPiece
28+ , levelGeo :: Geo
35− -- building the geo image is expensive. Cache it. Though VTY should go through greater lengths
29+ -- building the geo image is expensive. Cache it. Though VTY should go
36− -- to avoid the need to cache images.
30+ -- through greater lengths to avoid the need to cache images.
37− , geoImage :: Image
31+ , levelGeoImage :: Image
39 deriving (Show,Eq)
33 deriving (Show,Eq)
@@ -44,14 +38,20 @@ data LevelPiece
44 deriving (Show, Eq)
38 deriving (Show, Eq)
46type Game = RWST Vty () World IO
40type Game = RWST Vty () World IO
41+type Geo = Array Coord LevelPiece
42+type Coord = (Int, Int)
48−main = do
44+main :: IO ()
49 vty <- mkVty def
46 vty <- mkVty def
50 level0 <- mkLevel 1
47 level0 <- mkLevel 1
51− let world0 = World (Dude (fst $ start level0) (snd $ start level0)) level0
48+ let world0 = World (Player (levelStart level0)) level0
52− (_finalWorld, ()) <- execRWST (play >> updateDisplay) vty world0
49+ (_finalWorld, ()) <- execRWST play vty world0
53 shutdown vty
50 shutdown vty
52+-- |Generate a level randomly using the specified difficulty. Higher
53+-- difficulty means the level will have more rooms and cover a larger area.
54+mkLevel :: Int -> IO Level
55mkLevel difficulty = do
55mkLevel difficulty = do
56 let size = 80 * difficulty
56 let size = 80 * difficulty
57 [levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)
57 [levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)
@@ -59,7 +59,7 @@ mkLevel difficulty = do
59 start <- randomP
59 start <- randomP
60 end <- randomP
60 end <- randomP
61 -- first the base geography: all rocks
61 -- first the base geography: all rocks
62− let baseGeo = array ((0,0), (levelWidth, levelHeight))
62+ let baseGeo = array ((0,0), (levelWidth-1, levelHeight-1))
63 [((x,y),Rock) | x <- [0..levelWidth-1], y <- [0..levelHeight-1]]
63 [((x,y),Rock) | x <- [0..levelWidth-1], y <- [0..levelHeight-1]]
64 -- next the empty spaces that make the rooms
64 -- next the empty spaces that make the rooms
65 -- for this we generate a number of center points
65 -- for this we generate a number of center points
@@ -68,6 +68,16 @@ mkLevel difficulty = do
68 geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)
68 geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)
69 return $ Level start end geo (buildGeoImage geo)
69 return $ Level start end geo (buildGeoImage geo)
71+-- |Add a room to a geography and return a new geography. Adds a
72+-- randomly-sized room centered at the specified coordinates.
75+ -- ^The width and height of the geographical area
77+ -- ^The geographical area to which a new room should be added
79+ -- ^The desired center of the new room.
71addRoom levelWidth levelHeight geo (centerX, centerY) = do
81addRoom levelWidth levelHeight geo (centerX, centerY) = do
72 size <- randomRIO (5,15)
82 size <- randomRIO (5,15)
73 let xMin = max 1 (centerX - size)
83 let xMin = max 1 (centerX - size)
@@ -77,17 +87,17 @@ addRoom levelWidth levelHeight geo (centerX, centerY) = do
77 let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]
87 let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]
78 return (geo // room)
88 return (geo // room)
80−imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '
90+pieceA, dumpA :: Attr
81−imageForGeo Rock = char defAttr 'X'
83pieceA = defAttr `withForeColor` blue `withBackColor` green
91pieceA = defAttr `withForeColor` blue `withBackColor` green
84dumpA = defAttr `withStyle` reverseVideo
92dumpA = defAttr `withStyle` reverseVideo
87 updateDisplay
96 updateDisplay
88 done <- processEvent
97 done <- processEvent
89 unless done play
98 unless done play
100+processEvent :: Game Bool
91processEvent = do
101processEvent = do
92 k <- ask >>= liftIO . nextEvent
102 k <- ask >>= liftIO . nextEvent
93 if k == EvKey KEsc []
103 if k == EvKey KEsc []
@@ -95,49 +105,60 @@ processEvent = do
96 case k of
106 case k of
97 EvKey (KChar 'r') [MCtrl] -> ask >>= liftIO . refresh
107 EvKey (KChar 'r') [MCtrl] -> ask >>= liftIO . refresh
98− EvKey KLeft [] -> moveDude (-1) 0
108+ EvKey KLeft [] -> movePlayer (-1) 0
99− EvKey KRight [] -> moveDude 1 0
109+ EvKey KRight [] -> movePlayer 1 0
100− EvKey KUp [] -> moveDude 0 (-1)
110+ EvKey KUp [] -> movePlayer 0 (-1)
101− EvKey KDown [] -> moveDude 0 1
111+ EvKey KDown [] -> movePlayer 0 1
102 _ -> return ()
112 _ -> return ()
103 return False
113 return False
115+movePlayer :: Int -> Int -> Game ()
105−moveDude dx dy = do
116+movePlayer dx dy = do
107 world <- get
117 world <- get
108− let Dude x y = dude world
118+ let Player (x, y) = player world
109 let x' = x + dx
119 let x' = x + dx
110 y' = y + dy
120 y' = y + dy
111− -- this is only valid because the level generation assures the border is always Rock
121+ -- this is only valid because the level generation assures the border is
112− case geo (level world) ! (x',y') of
123+ case levelGeo (level world) ! (x',y') of
113− EmptySpace -> put $ world { dude = Dude x' y' }
124+ EmptySpace -> put $ world { player = Player (x',y') }
114 _ -> return ()
125 _ -> return ()
116updateDisplay :: Game ()
127updateDisplay :: Game ()
117updateDisplay = do
128updateDisplay = do
118 let info = string defAttr "Move with the arrows keys. Press ESC to exit."
129 let info = string defAttr "Move with the arrows keys. Press ESC to exit."
119− -- determine offsets to place the dude in the center of the level.
130+ -- determine offsets to place the player in the center of the level.
120 (w,h) <- asks outputIface >>= liftIO . displayBounds
131 (w,h) <- asks outputIface >>= liftIO . displayBounds
121− theDude <- gets dude
132+ thePlayer <- gets player
122− let ox = (w `div` 2) - dudeX theDude
133+ let ox = (w `div` 2) - playerX thePlayer
123− oy = (h `div` 2) - dudeY theDude
134+ oy = (h `div` 2) - playerY thePlayer
124− -- translate the world images to place the dude in the center of the level.
135+ -- translate the world images to place the player in the center of the
125− world' <- map (translate ox oy) <$> world
137+ world' <- map (translate ox oy) <$> worldImages
126 let pic = picForLayers $ info : world'
138 let pic = picForLayers $ info : world'
127 vty <- ask
139 vty <- ask
128 liftIO $ update vty pic
140 liftIO $ update vty pic
143+-- Image-generation functions
130−world :: Game [Image]
146+worldImages :: Game [Image]
131−world = do
147+worldImages = do
132− theDude <- gets dude
148+ thePlayer <- gets player
133 theLevel <- gets level
149 theLevel <- gets level
134− let dudeImage = translate (dudeX theDude) (dudeY theDude) (char pieceA '@')
150+ let playerImage = translate (playerX thePlayer) (playerY thePlayer) (char pieceA '@')
135− return [dudeImage, geoImage theLevel]
151+ return [playerImage, levelGeoImage theLevel]
153+imageForGeo :: LevelPiece -> Image
154+imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '
155+imageForGeo Rock = char defAttr 'X'
157+buildGeoImage :: Geo -> Image
137buildGeoImage geo =
158buildGeoImage geo =
138 let (geoWidth, geoHeight) = snd $ bounds geo
159 let (geoWidth, geoHeight) = snd $ bounds geo
139− -- seems like a the repeated index operation should be removable. This is not performing random
160+ -- seems like a the repeated index operation should be removable. This is
140− -- access but (presumably) access in order of index.
161+ -- not performing random access but (presumably) access in order of index.
141 in vertCat [ geoRow
162 in vertCat [ geoRow
142 | y <- [0..geoHeight-1]
163 | y <- [0..geoHeight-1]
143 , let geoRow = horizCat [ i
164 , let geoRow = horizCat [ i
@@ -145,3 +166,12 @@ buildGeoImage geo =
145 , let i = imageForGeo (geo ! (x,y))
166 , let i = imageForGeo (geo ! (x,y))
173+playerX :: Player -> Int
174+playerX = fst . playerCoord
176+playerY :: Player -> Int
177+playerY = snd . playerCoord