git.iko.soy/vty
on master help sign in
Rogue: clean up warnings (add type signatures, avoid overlapping names)
668ec34Jonathan Daugherty
test/Rogue.hs+20−11
compare with master
unifiedsplit
@@ -29,12 +29,12 @@ data World = World
29 deriving (Show,Eq)
29 deriving (Show,Eq)
30
30
31data Level = Level
31data Level = Level
32− { start :: (Int, Int)
32+ { levelStart :: (Int, Int)
33− , end :: (Int, Int)
33+ , levelEnd :: (Int, Int)
34− , geo :: Array (Int, Int) LevelPiece
34+ , levelGeo :: Array (Int, Int) LevelPiece
35 -- building the geo image is expensive. Cache it. Though VTY should go through greater lengths
35 -- building the geo image is expensive. Cache it. Though VTY should go through greater lengths
36 -- to avoid the need to cache images.
36 -- to avoid the need to cache images.
37− , geoImage :: Image
37+ , levelGeoImage :: Image
38 }
38 }
39 deriving (Show,Eq)
39 deriving (Show,Eq)
40
40
@@ -45,13 +45,15 @@ data LevelPiece
45
45
46type Game = RWST Vty () World IO
46type Game = RWST Vty () World IO
47
47
48+main :: IO ()
48main = do
49main = do
49 vty <- mkVty def
50 vty <- mkVty def
50 level0 <- mkLevel 1
51 level0 <- mkLevel 1
51− let world0 = World (Dude (fst $ start level0) (snd $ start level0)) level0
52+ let world0 = World (Dude (fst $ levelStart level0) (snd $ levelStart level0)) level0
52 (_finalWorld, ()) <- execRWST (play >> updateDisplay) vty world0
53 (_finalWorld, ()) <- execRWST (play >> updateDisplay) vty world0
53 shutdown vty
54 shutdown vty
54
55
56+mkLevel :: Int -> IO Level
55mkLevel difficulty = do
57mkLevel difficulty = do
56 let size = 80 * difficulty
58 let size = 80 * difficulty
57 [levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)
59 [levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)
@@ -68,6 +70,8 @@ mkLevel difficulty = do
68 geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)
70 geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)
69 return $ Level start end geo (buildGeoImage geo)
71 return $ Level start end geo (buildGeoImage geo)
70
72
73+addRoom :: Int -> Int -> Array (Int, Int) LevelPiece -> (Int, Int)
74+ -> IO (Array (Int, Int) LevelPiece)
71addRoom levelWidth levelHeight geo (centerX, centerY) = do
75addRoom levelWidth levelHeight geo (centerX, centerY) = do
72 size <- randomRIO (5,15)
76 size <- randomRIO (5,15)
73 let xMin = max 1 (centerX - size)
77 let xMin = max 1 (centerX - size)
@@ -77,17 +81,21 @@ addRoom levelWidth levelHeight geo (centerX, centerY) = do
77 let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]
81 let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]
78 return (geo // room)
82 return (geo // room)
79
83
84+imageForGeo :: LevelPiece -> Image
80imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '
85imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '
81imageForGeo Rock = char defAttr 'X'
86imageForGeo Rock = char defAttr 'X'
82
87
88+pieceA, dumpA :: Attr
83pieceA = defAttr `withForeColor` blue `withBackColor` green
89pieceA = defAttr `withForeColor` blue `withBackColor` green
84dumpA = defAttr `withStyle` reverseVideo
90dumpA = defAttr `withStyle` reverseVideo
85
91
92+play :: Game ()
86play = do
93play = do
87 updateDisplay
94 updateDisplay
88 done <- processEvent
95 done <- processEvent
89 unless done play
96 unless done play
90
97
98+processEvent :: Game Bool
91processEvent = do
99processEvent = do
92 k <- ask >>= liftIO . nextEvent
100 k <- ask >>= liftIO . nextEvent
93 if k == EvKey KEsc []
101 if k == EvKey KEsc []
@@ -102,14 +110,14 @@ processEvent = do
102 _ -> return ()
110 _ -> return ()
103 return False
111 return False
104
112
113+moveDude :: Int -> Int -> Game ()
105moveDude dx dy = do
114moveDude dx dy = do
106− vty <- ask
107 world <- get
115 world <- get
108 let Dude x y = dude world
116 let Dude x y = dude world
109 let x' = x + dx
117 let x' = x + dx
110 y' = y + dy
118 y' = y + dy
111 -- this is only valid because the level generation assures the border is always Rock
119 -- this is only valid because the level generation assures the border is always Rock
112− case geo (level world) ! (x',y') of
120+ case levelGeo (level world) ! (x',y') of
113 EmptySpace -> put $ world { dude = Dude x' y' }
121 EmptySpace -> put $ world { dude = Dude x' y' }
114 _ -> return ()
122 _ -> return ()
115
123
@@ -122,18 +130,19 @@ updateDisplay = do
122 let ox = (w `div` 2) - dudeX theDude
130 let ox = (w `div` 2) - dudeX theDude
123 oy = (h `div` 2) - dudeY theDude
131 oy = (h `div` 2) - dudeY theDude
124 -- translate the world images to place the dude in the center of the level.
132 -- translate the world images to place the dude in the center of the level.
125− world' <- map (translate ox oy) <$> world
133+ world' <- map (translate ox oy) <$> worldImages
126 let pic = picForLayers $ info : world'
134 let pic = picForLayers $ info : world'
127 vty <- ask
135 vty <- ask
128 liftIO $ update vty pic
136 liftIO $ update vty pic
129
137
130−world :: Game [Image]
138+worldImages :: Game [Image]
131−world = do
139+worldImages = do
132 theDude <- gets dude
140 theDude <- gets dude
133 theLevel <- gets level
141 theLevel <- gets level
134 let dudeImage = translate (dudeX theDude) (dudeY theDude) (char pieceA '@')
142 let dudeImage = translate (dudeX theDude) (dudeY theDude) (char pieceA '@')
135− return [dudeImage, geoImage theLevel]
143+ return [dudeImage, levelGeoImage theLevel]
136
144
145+buildGeoImage :: Array (Int, Int) LevelPiece -> Image
137buildGeoImage geo =
146buildGeoImage geo =
138 let (geoWidth, geoHeight) = snd $ bounds geo
147 let (geoWidth, geoHeight) = snd $ bounds geo
139 -- seems like a the repeated index operation should be removable. This is not performing random
148 -- seems like a the repeated index operation should be removable. This is not performing random