mirror of
https://github.com/ilyakooo0/vty.git
synced 2024-10-04 11:17:08 +03:00
Rogue: clean up warnings (add type signatures, avoid overlapping names)
This commit is contained in:
parent
f9757bc01b
commit
668ec34424
@ -29,12 +29,12 @@ data World = World
|
|||||||
deriving (Show,Eq)
|
deriving (Show,Eq)
|
||||||
|
|
||||||
data Level = Level
|
data Level = Level
|
||||||
{ start :: (Int, Int)
|
{ levelStart :: (Int, Int)
|
||||||
, end :: (Int, Int)
|
, levelEnd :: (Int, Int)
|
||||||
, geo :: Array (Int, Int) LevelPiece
|
, levelGeo :: Array (Int, Int) LevelPiece
|
||||||
-- building the geo image is expensive. Cache it. Though VTY should go through greater lengths
|
-- building the geo image is expensive. Cache it. Though VTY should go through greater lengths
|
||||||
-- to avoid the need to cache images.
|
-- to avoid the need to cache images.
|
||||||
, geoImage :: Image
|
, levelGeoImage :: Image
|
||||||
}
|
}
|
||||||
deriving (Show,Eq)
|
deriving (Show,Eq)
|
||||||
|
|
||||||
@ -45,13 +45,15 @@ data LevelPiece
|
|||||||
|
|
||||||
type Game = RWST Vty () World IO
|
type Game = RWST Vty () World IO
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
vty <- mkVty def
|
vty <- mkVty def
|
||||||
level0 <- mkLevel 1
|
level0 <- mkLevel 1
|
||||||
let world0 = World (Dude (fst $ start level0) (snd $ start level0)) level0
|
let world0 = World (Dude (fst $ levelStart level0) (snd $ levelStart level0)) level0
|
||||||
(_finalWorld, ()) <- execRWST (play >> updateDisplay) vty world0
|
(_finalWorld, ()) <- execRWST (play >> updateDisplay) vty world0
|
||||||
shutdown vty
|
shutdown vty
|
||||||
|
|
||||||
|
mkLevel :: Int -> IO Level
|
||||||
mkLevel difficulty = do
|
mkLevel difficulty = do
|
||||||
let size = 80 * difficulty
|
let size = 80 * difficulty
|
||||||
[levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)
|
[levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)
|
||||||
@ -68,6 +70,8 @@ mkLevel difficulty = do
|
|||||||
geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)
|
geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)
|
||||||
return $ Level start end geo (buildGeoImage geo)
|
return $ Level start end geo (buildGeoImage geo)
|
||||||
|
|
||||||
|
addRoom :: Int -> Int -> Array (Int, Int) LevelPiece -> (Int, Int)
|
||||||
|
-> IO (Array (Int, Int) LevelPiece)
|
||||||
addRoom levelWidth levelHeight geo (centerX, centerY) = do
|
addRoom levelWidth levelHeight geo (centerX, centerY) = do
|
||||||
size <- randomRIO (5,15)
|
size <- randomRIO (5,15)
|
||||||
let xMin = max 1 (centerX - size)
|
let xMin = max 1 (centerX - size)
|
||||||
@ -77,17 +81,21 @@ addRoom levelWidth levelHeight geo (centerX, centerY) = do
|
|||||||
let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]
|
let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]
|
||||||
return (geo // room)
|
return (geo // room)
|
||||||
|
|
||||||
|
imageForGeo :: LevelPiece -> Image
|
||||||
imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '
|
imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '
|
||||||
imageForGeo Rock = char defAttr 'X'
|
imageForGeo Rock = char defAttr 'X'
|
||||||
|
|
||||||
|
pieceA, dumpA :: Attr
|
||||||
pieceA = defAttr `withForeColor` blue `withBackColor` green
|
pieceA = defAttr `withForeColor` blue `withBackColor` green
|
||||||
dumpA = defAttr `withStyle` reverseVideo
|
dumpA = defAttr `withStyle` reverseVideo
|
||||||
|
|
||||||
|
play :: Game ()
|
||||||
play = do
|
play = do
|
||||||
updateDisplay
|
updateDisplay
|
||||||
done <- processEvent
|
done <- processEvent
|
||||||
unless done play
|
unless done play
|
||||||
|
|
||||||
|
processEvent :: Game Bool
|
||||||
processEvent = do
|
processEvent = do
|
||||||
k <- ask >>= liftIO . nextEvent
|
k <- ask >>= liftIO . nextEvent
|
||||||
if k == EvKey KEsc []
|
if k == EvKey KEsc []
|
||||||
@ -102,14 +110,14 @@ processEvent = do
|
|||||||
_ -> return ()
|
_ -> return ()
|
||||||
return False
|
return False
|
||||||
|
|
||||||
|
moveDude :: Int -> Int -> Game ()
|
||||||
moveDude dx dy = do
|
moveDude dx dy = do
|
||||||
vty <- ask
|
|
||||||
world <- get
|
world <- get
|
||||||
let Dude x y = dude world
|
let Dude x y = dude world
|
||||||
let x' = x + dx
|
let x' = x + dx
|
||||||
y' = y + dy
|
y' = y + dy
|
||||||
-- this is only valid because the level generation assures the border is always Rock
|
-- this is only valid because the level generation assures the border is always Rock
|
||||||
case geo (level world) ! (x',y') of
|
case levelGeo (level world) ! (x',y') of
|
||||||
EmptySpace -> put $ world { dude = Dude x' y' }
|
EmptySpace -> put $ world { dude = Dude x' y' }
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
|
||||||
@ -122,18 +130,19 @@ updateDisplay = do
|
|||||||
let ox = (w `div` 2) - dudeX theDude
|
let ox = (w `div` 2) - dudeX theDude
|
||||||
oy = (h `div` 2) - dudeY theDude
|
oy = (h `div` 2) - dudeY theDude
|
||||||
-- translate the world images to place the dude in the center of the level.
|
-- translate the world images to place the dude in the center of the level.
|
||||||
world' <- map (translate ox oy) <$> world
|
world' <- map (translate ox oy) <$> worldImages
|
||||||
let pic = picForLayers $ info : world'
|
let pic = picForLayers $ info : world'
|
||||||
vty <- ask
|
vty <- ask
|
||||||
liftIO $ update vty pic
|
liftIO $ update vty pic
|
||||||
|
|
||||||
world :: Game [Image]
|
worldImages :: Game [Image]
|
||||||
world = do
|
worldImages = do
|
||||||
theDude <- gets dude
|
theDude <- gets dude
|
||||||
theLevel <- gets level
|
theLevel <- gets level
|
||||||
let dudeImage = translate (dudeX theDude) (dudeY theDude) (char pieceA '@')
|
let dudeImage = translate (dudeX theDude) (dudeY theDude) (char pieceA '@')
|
||||||
return [dudeImage, geoImage theLevel]
|
return [dudeImage, levelGeoImage theLevel]
|
||||||
|
|
||||||
|
buildGeoImage :: Array (Int, Int) LevelPiece -> Image
|
||||||
buildGeoImage geo =
|
buildGeoImage geo =
|
||||||
let (geoWidth, geoHeight) = snd $ bounds geo
|
let (geoWidth, geoHeight) = snd $ bounds geo
|
||||||
-- seems like a the repeated index operation should be removable. This is not performing random
|
-- seems like a the repeated index operation should be removable. This is not performing random
|
||||||
|
Loading…
Reference in New Issue
Block a user