@@ -4,37 +4,31 @@ module Main where
44import Graphics.Vty
55
66import Data.Array
7−import qualified Data.ByteString as B
87import Data.Default (def)
9−import Data.Word
108
119import Control.Applicative
12−import Control.Lens hiding (Level)
1310import Control.Monad
1411import Control.Monad.RWS
15−import Control.Monad.Writer
1612
17−import System.IO
1813import System.Random
1914
20−data Dude = Dude
21− { dudeX :: Int
22− , dudeY :: Int
15+data Player = Player
16+ { playerCoord :: Coord
2317 } deriving (Show,Eq)
2418
2519data World = World
26− { dude :: Dude
20+ { player :: Player
2721 , level :: Level
2822 }
2923 deriving (Show,Eq)
3024
3125data Level = Level
32− { start :: (Int, Int)
33− , end :: (Int, Int)
34− , geo :: Array (Int, Int) LevelPiece
35− -- building the geo image is expensive. Cache it. Though VTY should go through greater lengths
36− -- to avoid the need to cache images.
37− , geoImage :: Image
26+ { levelStart :: Coord
27+ , levelEnd :: Coord
28+ , levelGeo :: Geo
29+ -- building the geo image is expensive. Cache it. Though VTY should go
30+ -- through greater lengths to avoid the need to cache images.
31+ , levelGeoImage :: Image
3832 }
3933 deriving (Show,Eq)
4034
@@ -44,14 +38,20 @@ data LevelPiece
4438 deriving (Show, Eq)
4539
4640type Game = RWST Vty () World IO
41+type Geo = Array Coord LevelPiece
42+type Coord = (Int, Int)
4743
48−main = do
44+main :: IO ()
45+main = do
4946 vty <- mkVty def
5047 level0 <- mkLevel 1
51− let world0 = World (Dude (fst $ start level0) (snd $ start level0)) level0
52− (_finalWorld, ()) <- execRWST (play >> updateDisplay) vty world0
48+ let world0 = World (Player (levelStart level0)) level0
49+ (_finalWorld, ()) <- execRWST play vty world0
5350 shutdown vty
5451
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
5555mkLevel difficulty = do
5656 let size = 80 * difficulty
5757 [levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)
@@ -59,7 +59,7 @@ mkLevel difficulty = do
5959 start <- randomP
6060 end <- randomP
6161 -- first the base geography: all rocks
62− let baseGeo = array ((0,0), (levelWidth, levelHeight))
62+ let baseGeo = array ((0,0), (levelWidth-1, levelHeight-1))
6363 [((x,y),Rock) | x <- [0..levelWidth-1], y <- [0..levelHeight-1]]
6464 -- next the empty spaces that make the rooms
6565 -- for this we generate a number of center points
@@ -68,6 +68,16 @@ mkLevel difficulty = do
6868 geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)
6969 return $ Level start end geo (buildGeoImage geo)
7070
71+-- |Add a room to a geography and return a new geography. Adds a
72+-- randomly-sized room centered at the specified coordinates.
73+addRoom :: Int
74+ -> Int
75+ -- ^The width and height of the geographical area
76+ -> Geo
77+ -- ^The geographical area to which a new room should be added
78+ -> Coord
79+ -- ^The desired center of the new room.
80+ -> IO Geo
7181addRoom levelWidth levelHeight geo (centerX, centerY) = do
7282 size <- randomRIO (5,15)
7383 let xMin = max 1 (centerX - size)
@@ -77,17 +87,17 @@ addRoom levelWidth levelHeight geo (centerX, centerY) = do
7787 let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]
7888 return (geo // room)
7989
80−imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '
81−imageForGeo Rock = char defAttr 'X'
82−
90+pieceA, dumpA :: Attr
8391pieceA = defAttr `withForeColor` blue `withBackColor` green
8492dumpA = defAttr `withStyle` reverseVideo
8593
94+play :: Game ()
8695play = do
8796 updateDisplay
8897 done <- processEvent
8998 unless done play
9099
100+processEvent :: Game Bool
91101processEvent = do
92102 k <- ask >>= liftIO . nextEvent
93103 if k == EvKey KEsc []
@@ -95,49 +105,60 @@ processEvent = do
95105 else do
96106 case k of
97107 EvKey (KChar 'r') [MCtrl] -> ask >>= liftIO . refresh
98− EvKey KLeft [] -> moveDude (-1) 0
99− EvKey KRight [] -> moveDude 1 0
100− EvKey KUp [] -> moveDude 0 (-1)
101− EvKey KDown [] -> moveDude 0 1
108+ EvKey KLeft [] -> movePlayer (-1) 0
109+ EvKey KRight [] -> movePlayer 1 0
110+ EvKey KUp [] -> movePlayer 0 (-1)
111+ EvKey KDown [] -> movePlayer 0 1
102112 _ -> return ()
103113 return False
104114
105−moveDude dx dy = do
106− vty <- ask
115+movePlayer :: Int -> Int -> Game ()
116+movePlayer dx dy = do
107117 world <- get
108− let Dude x y = dude world
118+ let Player (x, y) = player world
109119 let x' = x + dx
110120 y' = y + dy
111− -- this is only valid because the level generation assures the border is always Rock
112− case geo (level world) ! (x',y') of
113− EmptySpace -> put $ world { dude = Dude x' y' }
121+ -- this is only valid because the level generation assures the border is
122+ -- always Rock
123+ case levelGeo (level world) ! (x',y') of
124+ EmptySpace -> put $ world { player = Player (x',y') }
114125 _ -> return ()
115126
116127updateDisplay :: Game ()
117128updateDisplay = do
118129 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.
120131 (w,h) <- asks outputIface >>= liftIO . displayBounds
121− theDude <- gets dude
122− let ox = (w `div` 2) - dudeX theDude
123− oy = (h `div` 2) - dudeY theDude
124− -- translate the world images to place the dude in the center of the level.
125− world' <- map (translate ox oy) <$> world
132+ thePlayer <- gets player
133+ let ox = (w `div` 2) - playerX thePlayer
134+ oy = (h `div` 2) - playerY thePlayer
135+ -- translate the world images to place the player in the center of the
136+ -- level.
137+ world' <- map (translate ox oy) <$> worldImages
126138 let pic = picForLayers $ info : world'
127139 vty <- ask
128140 liftIO $ update vty pic
129141
130−world :: Game [Image]
131−world = do
132− theDude <- gets dude
142+--
143+-- Image-generation functions
144+--
145+
146+worldImages :: Game [Image]
147+worldImages = do
148+ thePlayer <- gets player
133149 theLevel <- gets level
134− let dudeImage = translate (dudeX theDude) (dudeY theDude) (char pieceA '@')
135− return [dudeImage, geoImage theLevel]
150+ let playerImage = translate (playerX thePlayer) (playerY thePlayer) (char pieceA '@')
151+ return [playerImage, levelGeoImage theLevel]
136152
153+imageForGeo :: LevelPiece -> Image
154+imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '
155+imageForGeo Rock = char defAttr 'X'
156+
157+buildGeoImage :: Geo -> Image
137158buildGeoImage geo =
138159 let (geoWidth, geoHeight) = snd $ bounds geo
139− -- seems like a the repeated index operation should be removable. This is not performing random
140− -- access but (presumably) access in order of index.
160+ -- seems like a the repeated index operation should be removable. This is
161+ -- not performing random access but (presumably) access in order of index.
141162 in vertCat [ geoRow
142163 | y <- [0..geoHeight-1]
143164 , let geoRow = horizCat [ i
@@ -145,3 +166,12 @@ buildGeoImage geo =
145166 , let i = imageForGeo (geo ! (x,y))
146167 ]
147168 ]
169+
170+--
171+-- Miscellaneous
172+--
173+playerX :: Player -> Int
174+playerX = fst . playerCoord
175+
176+playerY :: Player -> Int
177+playerY = snd . playerCoord