vty-examples 5.0.1 → 5.2.0
raw patch · 4 files changed
+199/−169 lines, 4 filesnew-component:exe:vty-rogue
Files
- Rogue.hs +177/−0
- Rouge.hs +0/−147
- interactive_terminal_test.hs +18/−18
- vty-examples.cabal +4/−4
+ Rogue.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import Graphics.Vty++import Data.Array+import Data.Default (def)++import Control.Applicative+import Control.Monad+import Control.Monad.RWS++import System.Random++data Player = Player+ { playerCoord :: Coord+ } deriving (Show,Eq)++data World = World+ { player :: Player+ , level :: Level+ }+ deriving (Show,Eq)++data Level = Level+ { levelStart :: Coord+ , levelEnd :: Coord+ , levelGeo :: Geo+ -- building the geo image is expensive. Cache it. Though VTY should go+ -- through greater lengths to avoid the need to cache images.+ , levelGeoImage :: Image+ }+ deriving (Show,Eq)++data LevelPiece+ = EmptySpace+ | Rock+ deriving (Show, Eq)++type Game = RWST Vty () World IO+type Geo = Array Coord LevelPiece+type Coord = (Int, Int)++main :: IO ()+main = do+ vty <- mkVty def+ level0 <- mkLevel 1+ let world0 = World (Player (levelStart level0)) level0+ (_finalWorld, ()) <- execRWST play vty world0+ shutdown vty++-- |Generate a level randomly using the specified difficulty. Higher+-- difficulty means the level will have more rooms and cover a larger area.+mkLevel :: Int -> IO Level+mkLevel difficulty = do+ let size = 80 * difficulty+ [levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)+ let randomP = (,) <$> randomRIO (2, levelWidth-3) <*> randomRIO (2, levelHeight-3)+ start <- randomP+ end <- randomP+ -- first the base geography: all rocks+ let baseGeo = array ((0,0), (levelWidth-1, levelHeight-1))+ [((x,y),Rock) | x <- [0..levelWidth-1], y <- [0..levelHeight-1]]+ -- next the empty spaces that make the rooms+ -- for this we generate a number of center points+ centers <- replicateM (2 ^ difficulty + difficulty) randomP+ -- generate rooms for all those points, plus the start and end+ geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)+ return $ Level start end geo (buildGeoImage geo)++-- |Add a room to a geography and return a new geography. Adds a+-- randomly-sized room centered at the specified coordinates.+addRoom :: Int+ -> Int+ -- ^The width and height of the geographical area+ -> Geo+ -- ^The geographical area to which a new room should be added+ -> Coord+ -- ^The desired center of the new room.+ -> IO Geo+addRoom levelWidth levelHeight geo (centerX, centerY) = do+ size <- randomRIO (5,15)+ let xMin = max 1 (centerX - size)+ xMax = min (levelWidth - 1) (centerX + size)+ yMin = max 1 (centerY - size)+ yMax = min (levelHeight - 1) (centerY + size)+ let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]+ return (geo // room)++pieceA, dumpA :: Attr+pieceA = defAttr `withForeColor` blue `withBackColor` green+dumpA = defAttr `withStyle` reverseVideo++play :: Game ()+play = do+ updateDisplay+ done <- processEvent+ unless done play++processEvent :: Game Bool+processEvent = do+ k <- ask >>= liftIO . nextEvent+ if k == EvKey KEsc []+ then return True+ else do+ case k of+ EvKey (KChar 'r') [MCtrl] -> ask >>= liftIO . refresh+ EvKey KLeft [] -> movePlayer (-1) 0+ EvKey KRight [] -> movePlayer 1 0+ EvKey KUp [] -> movePlayer 0 (-1)+ EvKey KDown [] -> movePlayer 0 1+ _ -> return ()+ return False++movePlayer :: Int -> Int -> Game ()+movePlayer dx dy = do+ world <- get+ let Player (x, y) = player world+ let x' = x + dx+ y' = y + dy+ -- this is only valid because the level generation assures the border is+ -- always Rock+ case levelGeo (level world) ! (x',y') of+ EmptySpace -> put $ world { player = Player (x',y') }+ _ -> return ()++updateDisplay :: Game ()+updateDisplay = do+ let info = string defAttr "Move with the arrows keys. Press ESC to exit."+ -- determine offsets to place the player in the center of the level.+ (w,h) <- asks outputIface >>= liftIO . displayBounds+ thePlayer <- gets player+ let ox = (w `div` 2) - playerX thePlayer+ oy = (h `div` 2) - playerY thePlayer+ -- translate the world images to place the player in the center of the+ -- level.+ world' <- map (translate ox oy) <$> worldImages+ let pic = picForLayers $ info : world'+ vty <- ask+ liftIO $ update vty pic++--+-- Image-generation functions+--++worldImages :: Game [Image]+worldImages = do+ thePlayer <- gets player+ theLevel <- gets level+ let playerImage = translate (playerX thePlayer) (playerY thePlayer) (char pieceA '@')+ return [playerImage, levelGeoImage theLevel]++imageForGeo :: LevelPiece -> Image+imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '+imageForGeo Rock = char defAttr 'X'++buildGeoImage :: Geo -> Image+buildGeoImage geo =+ let (geoWidth, geoHeight) = snd $ bounds geo+ -- seems like a the repeated index operation should be removable. This is+ -- not performing random access but (presumably) access in order of index.+ in vertCat [ geoRow+ | y <- [0..geoHeight-1]+ , let geoRow = horizCat [ i+ | x <- [0..geoWidth-1]+ , let i = imageForGeo (geo ! (x,y))+ ]+ ]++--+-- Miscellaneous+--+playerX :: Player -> Int+playerX = fst . playerCoord++playerY :: Player -> Int+playerY = snd . playerCoord
− Rouge.hs
@@ -1,147 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Main where--import Graphics.Vty--import Data.Array-import qualified Data.ByteString as B-import Data.Default (def)-import Data.Word--import Control.Applicative-import Control.Lens hiding (Level)-import Control.Monad-import Control.Monad.RWS-import Control.Monad.Writer--import System.IO-import System.Random--data Dude = Dude- { dudeX :: Int- , dudeY :: Int- } deriving (Show,Eq)--data World = World- { dude :: Dude- , level :: Level- }- deriving (Show,Eq)--data Level = Level- { start :: (Int, Int)- , end :: (Int, Int)- , geo :: Array (Int, Int) LevelPiece- -- building the geo image is expensive. Cache it. Though VTY should go through greater lengths- -- to avoid the need to cache images.- , geoImage :: Image- }- deriving (Show,Eq)--data LevelPiece- = EmptySpace- | Rock- deriving (Show, Eq)--type Game = RWST Vty () World IO--main = do - vty <- mkVty def- level0 <- mkLevel 1- let world0 = World (Dude (fst $ start level0) (snd $ start level0)) level0- (_finalWorld, ()) <- execRWST (play >> updateDisplay) vty world0- shutdown vty--mkLevel difficulty = do- let size = 80 * difficulty- [levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)- let randomP = (,) <$> randomRIO (2, levelWidth-3) <*> randomRIO (2, levelHeight-3)- start <- randomP- end <- randomP- -- first the base geography: all rocks- let baseGeo = array ((0,0), (levelWidth, levelHeight))- [((x,y),Rock) | x <- [0..levelWidth-1], y <- [0..levelHeight-1]]- -- next the empty spaces that make the rooms- -- for this we generate a number of center points- centers <- replicateM (2 ^ difficulty + difficulty) randomP- -- generate rooms for all those points, plus the start and end- geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)- return $ Level start end geo (buildGeoImage geo)--addRoom levelWidth levelHeight geo (centerX, centerY) = do- size <- randomRIO (5,15)- let xMin = max 1 (centerX - size)- xMax = min (levelWidth - 1) (centerX + size)- yMin = max 1 (centerY - size)- yMax = min (levelHeight - 1) (centerY + size)- let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]- return (geo // room)--imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '-imageForGeo Rock = char defAttr 'X'--pieceA = defAttr `withForeColor` blue `withBackColor` green-dumpA = defAttr `withStyle` reverseVideo--play = do- updateDisplay- done <- processEvent- unless done play--processEvent = do- k <- ask >>= liftIO . nextEvent- if k == EvKey KEsc []- then return True- else do- case k of- EvKey (KChar 'r') [MCtrl] -> ask >>= liftIO . refresh- EvKey KLeft [] -> moveDude (-1) 0- EvKey KRight [] -> moveDude 1 0- EvKey KUp [] -> moveDude 0 (-1)- EvKey KDown [] -> moveDude 0 1- _ -> return ()- return False--moveDude dx dy = do- vty <- ask- world <- get- let Dude x y = dude world- let x' = x + dx- y' = y + dy- -- this is only valid because the level generation assures the border is always Rock- case geo (level world) ! (x',y') of- EmptySpace -> put $ world { dude = Dude x' y' }- _ -> return ()--updateDisplay :: Game ()-updateDisplay = do- let info = string defAttr "Move with the arrows keys. Press ESC to exit."- -- determine offsets to place the dude in the center of the level.- (w,h) <- asks outputIface >>= liftIO . displayBounds- theDude <- gets dude- let ox = (w `div` 2) - dudeX theDude- oy = (h `div` 2) - dudeY theDude- -- translate the world images to place the dude in the center of the level.- world' <- map (translate ox oy) <$> world- let pic = picForLayers $ info : world'- vty <- ask- liftIO $ update vty pic--world :: Game [Image]-world = do- theDude <- gets dude- theLevel <- gets level- let dudeImage = translate (dudeX theDude) (dudeY theDude) (char pieceA '@')- return [dudeImage, geoImage theLevel]--buildGeoImage geo =- let (geoWidth, geoHeight) = snd $ bounds geo- -- seems like a the repeated index operation should be removable. This is not performing random- -- access but (presumably) access in order of index.- in vertCat [ geoRow- | y <- [0..geoHeight-1]- , let geoRow = horizCat [ i- | x <- [0..geoWidth-1]- , let i = imageForGeo (geo ! (x,y))- ]- ]
interactive_terminal_test.hs view
@@ -78,7 +78,7 @@ ( \ (_ :: SomeException) -> return (envName, "") ) ) [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig let resultsTxt = show envAttributes ++ "\n" ++ terminalID t ++ "\n" ++ show results ++ "\n"@@ -189,7 +189,7 @@ { testName = "Initialize and reserve terminal output then restore previous state." , testID = "reserveOutputTest" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t putStrLn "Line 1" putStrLn "Line 2"@@ -222,7 +222,7 @@ { testName = "Verify display bounds are correct test 0: Using spaces." , testID = "displayBoundsTest0" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t (w,h) <- displayBounds t let row0 = replicate (fromEnum w) 'X' ++ "\n"@@ -243,7 +243,7 @@ { testName = "Verify display bounds are correct test 0: Using cursor movement." , testID = "displayBoundsTest1" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t (w,h) <- displayBounds t setCursorPos t 0 0@@ -272,7 +272,7 @@ { testName = "Verify display bounds are correct test 0: Using Image ops." , testID = "displayBoundsTest2" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t bounds@(w,h) <- displayBounds t let firstRow = horizCat $ replicate (fromEnum w) (char defAttr 'X')@@ -295,7 +295,7 @@ { testName = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos." , testID = "displayBoundsTest3" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t (w,h) <- displayBounds t hideCursor t@@ -407,7 +407,7 @@ { testName = "Verify terminal can display unicode single-width characters. (Direct UTF-8)" , testID = "unicodeSingleWidth0" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t hideCursor t withArrayLen (concat utf8Txt0) (flip $ hPutBuf stdout)@@ -426,7 +426,7 @@ { testName = "Verify terminal can display unicode single-width characters. (Image ops)" , testID = "unicodeSingleWidth1" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t let pic = picForImage image image = line0 <-> line1@@ -489,7 +489,7 @@ { testName = "Verify terminal can display unicode double-width characters. (Direct UTF-8)" , testID = "unicodeDoubleWidth0" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t hideCursor t withArrayLen (concat utf8Txt1) (flip $ hPutBuf stdout)@@ -508,7 +508,7 @@ { testName = "Verify terminal can display unicode double-width characters. (Image ops)" , testID = "unicodeDoubleWidth1" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t let pic = picForImage image image = line0 <-> line1@@ -562,7 +562,7 @@ { testName = "Character attributes: foreground colors." , testID = "attributesTest0" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t let pic = picForImage image image = border <|> column0 <|> border <|> column1 <|> border@@ -608,7 +608,7 @@ { testName = "Character attributes: background colors." , testID = "attributesTest1" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t let pic = picForImage image image = border <|> column0 <|> border <|> column1 <|> border@@ -663,7 +663,7 @@ { testName = "Character attributes: Vivid foreground colors." , testID = "attributesTest2" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t let pic = picForImage image image = horizCat [border, column0, border, column1, border, column2, border]@@ -722,7 +722,7 @@ { testName = "Character attributes: Vivid background colors." , testID = "attributesTest3" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t let pic = picForImage image image = horizCat [border, column0, border, column1, border, column2, border]@@ -800,7 +800,7 @@ { testName = "Character attributes: Bold; Blink; Underline." , testID = "attributesTest4" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t let pic = picForImage image image = horizCat [border, column0, border, column1, border]@@ -852,7 +852,7 @@ { testName = "Character attributes: 240 color palette" , testID = "attributesTest5" , testAction = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t let pic = picForImage image image = vertCat $ map horizCat $ splitColorImages colorImages@@ -963,7 +963,7 @@ outputPicAndWait :: Picture -> IO () outputPicAndWait pic = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t d <- displayBounds t >>= displayContext t outputPicture d pic@@ -1146,7 +1146,7 @@ cheesyAnim0 :: Image -> [Image] -> IO () cheesyAnim0 i background = do- t <- outputForCurrentTerminal def+ t <- standardIOConfig >>= outputForConfig reserveDisplay t bounds <- displayBounds t d <- displayContext t bounds
vty-examples.cabal view
@@ -1,5 +1,5 @@ name: vty-examples-version: 5.0.1+version: 5.2.0 license: BSD3 license-file: ../LICENSE author: AUTHORS@@ -13,7 +13,7 @@ . vty-interactive-terminal-test - interactive test. Useful for building a bug report for vtys author. vty-event-echo - view a input event log for vty. Example of interacting with user.- vty-rouge - A bad rouge-like game. Go from the entrance to exit. Example of layers+ vty-rogue - A bad rogue-like game. Go from the entrance to exit. Example of layers vty-benchmark - benchmarks vty. A series of tests that push random pictures to the terminal. . © Corey O'Connor; BSD3 license.@@ -64,8 +64,8 @@ utf8-string >= 0.3 && < 0.4, vector >= 0.7 -executable vty-rouge- main-is: Rouge.hs+executable vty-rogue+ main-is: Rogue.hs default-language: Haskell2010 default-extensions: ScopedTypeVariables