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