mirror of
https://github.com/ilyakooo0/vty.git
synced 2024-12-01 22:53:37 +03:00
make the start of a silly rouge like game
This commit is contained in:
Corey O'Connor
parent
635f971c2b
commit
0620fdc350
108
test/Rouge.hs
Normal file
108
test/Rouge.hs
Normal file
@ -0,0 +1,108 @@
|
||||
module Main where
|
||||
|
||||
import Graphics.Vty
|
||||
|
||||
import Data.Array
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Word
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.RWS
|
||||
import Control.Monad.Writer
|
||||
|
||||
import System.IO
|
||||
import System.Random
|
||||
|
||||
data Dude = Dude Int 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
|
||||
}
|
||||
deriving (Show,Eq)
|
||||
|
||||
data LevelPiece
|
||||
= EmptySpace
|
||||
| Rock
|
||||
deriving (Show, Eq)
|
||||
|
||||
type Game = RWST Vty () World IO
|
||||
|
||||
main = do
|
||||
vty <- mkVty
|
||||
level_0 <- mkLevel 0
|
||||
let world_0 = World (Dude (fst $ start level_0) (snd $ start level_0)) level_0
|
||||
(_final_world, ()) <- execRWST (play >> view_world) vty world_0
|
||||
shutdown vty
|
||||
|
||||
mkLevel _difficulty = do
|
||||
level_width <- randomRIO (10,15)
|
||||
level_height <- randomRIO (10,15)
|
||||
start <- (,) <$> randomRIO (2, level_width-3) <*> randomRIO (2, level_height-3)
|
||||
end <- (,) <$> randomRIO (2, level_width-3) <*> randomRIO (2, level_height-3)
|
||||
let geo = array ((0,0), (level_width, level_height))
|
||||
[((x,y),p) | x <- [0..level_width-1], y <- [0..level_height-1],
|
||||
let p = if (x == 0 || x == level_width-1) || (y==0 || y==level_height-1)
|
||||
then Rock
|
||||
else EmptySpace
|
||||
]
|
||||
return $ Level start end geo
|
||||
|
||||
image_for_geo EmptySpace = char (def_attr `with_back_color` green) ' '
|
||||
image_for_geo Rock = char (def_attr `with_fore_color` white) 'X'
|
||||
|
||||
pieceA = def_attr `with_fore_color` red
|
||||
dumpA = def_attr `with_style` reverse_video
|
||||
|
||||
play = do
|
||||
view_world
|
||||
done <- process_event
|
||||
unless done play
|
||||
|
||||
process_event = do
|
||||
k <- ask >>= liftIO . next_event
|
||||
if k == EvKey KEsc []
|
||||
then return True
|
||||
else do
|
||||
case k of
|
||||
EvKey (KASCII 'r') [MCtrl] -> ask >>= liftIO . refresh
|
||||
EvKey KLeft [] -> move_dude (-1) 0
|
||||
EvKey KRight [] -> move_dude 1 0
|
||||
EvKey KUp [] -> move_dude 0 (-1)
|
||||
EvKey KDown [] -> move_dude 0 1
|
||||
_ -> return ()
|
||||
return False
|
||||
|
||||
move_dude dx dy = do
|
||||
vty <- ask
|
||||
world <- get
|
||||
let Dude x y = dude world
|
||||
(w, h) <- gets (snd . bounds . geo . level)
|
||||
put $ world { dude = Dude (min (w - 2) $ max 1 (x + dx))
|
||||
(min (h - 2) $ max 1 (y + dy))
|
||||
}
|
||||
|
||||
view_world :: Game ()
|
||||
view_world = do
|
||||
Dude x y <- gets dude
|
||||
the_level <- gets level
|
||||
let dude_image = translate x y (char pieceA '@')
|
||||
let (geo_width, geo_height) = snd $ bounds (geo the_level)
|
||||
geo_image = vert_cat [ geo_row | y <- [0..geo_height-1],
|
||||
let geo_row = horiz_cat [ i | x <- [0..geo_width-1],
|
||||
let i = image_for_geo (geo the_level ! (x,y))
|
||||
]
|
||||
]
|
||||
info = string def_attr "Move with the arrows keys. Press ESC to exit."
|
||||
let pic = pic_for_layers [info, translate 0 1 dude_image,translate 0 1 geo_image]
|
||||
vty <- ask
|
||||
liftIO $ update vty pic
|
||||
43
test/Test.hs
43
test/Test.hs
@ -1,43 +0,0 @@
|
||||
module Main where
|
||||
|
||||
import Graphics.Vty
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Word
|
||||
|
||||
import System.IO
|
||||
|
||||
|
||||
main = do
|
||||
vt <- mkVty
|
||||
DisplayRegion w h <- display_bounds $ terminal vt
|
||||
putStrLn $ show $ DisplayRegion w h
|
||||
play vt 0 1 w h ""
|
||||
|
||||
pieceA = def_attr `with_fore_color` red
|
||||
dumpA = def_attr `with_style` reverse_video
|
||||
|
||||
play :: Vty -> Int -> Int -> Int -> Int -> String -> IO ()
|
||||
play vt x y sx sy btl = do update vt (current_pic x y sx sy btl)
|
||||
k <- next_event vt
|
||||
case k of EvKey (KASCII 'r') [MCtrl] -> refresh vt >> play vt x y sx sy btl
|
||||
EvKey KLeft [] | x /= 0 -> play vt (x-1) y sx sy btl
|
||||
EvKey KRight [] | x /= (sx-1) -> play vt (x+1) y sx sy btl
|
||||
EvKey KUp [] | y /= 1 -> play vt x (y-1) sx sy btl
|
||||
EvKey KDown [] | y /= (sy-2) -> play vt x (y+1) sx sy btl
|
||||
EvKey KEsc [] -> shutdown vt >> return ()
|
||||
EvResize nx ny -> play vt (min x (nx - 1))
|
||||
(min y (ny - 2))
|
||||
nx
|
||||
ny
|
||||
btl
|
||||
_ -> play vt x y sx sy (take sx (show k ++ btl))
|
||||
|
||||
|
||||
current_pic :: Int -> Int -> Int -> Int -> String -> Picture
|
||||
current_pic x y sx sy btl = pic_for_image i
|
||||
where i = string def_attr "Move the @ character around with the arrow keys. Escape exits."
|
||||
<-> char_fill pieceA ' ' sx (y - 1)
|
||||
<-> char_fill pieceA ' ' x 1 <|> char pieceA '@' <|> char_fill pieceA ' ' (sx - x - 1) 1
|
||||
<-> char_fill pieceA ' ' sx (sy - y - 2)
|
||||
<-> iso_10646_string dumpA btl
|
||||
@ -33,6 +33,9 @@ import Test.SmallCheck.Series
|
||||
max_block_size :: Int
|
||||
max_block_size = 16
|
||||
|
||||
forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
|
||||
forEachOf l = over (generate (\n -> take n l))
|
||||
|
||||
data InputEvent
|
||||
= Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
|
||||
| Delay Int -- | millisecond delay
|
||||
@ -78,34 +81,36 @@ write_input_spec_to_chan chan (Delay _t : input_spec') = do
|
||||
writeChan chan '\xFFFE'
|
||||
write_input_spec_to_chan chan input_spec'
|
||||
|
||||
newtype EventBlock event = EventBlock ([(String,event)] -> [(String, event)])
|
||||
newtype InputBlocksUsingTable event
|
||||
= InputBlocksUsingTable ([(String,event)] -> [(String, event)])
|
||||
|
||||
instance Show (EventBlock event) where
|
||||
show (EventBlock g) = "EventBlock(*->*)"
|
||||
instance Show (InputBlocksUsingTable event) where
|
||||
show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"
|
||||
|
||||
instance Monad m => Serial m (EventBlock event) where
|
||||
instance Monad m => Serial m (InputBlocksUsingTable event) where
|
||||
series = do
|
||||
n :: Int <- localDepth (max max_block_size) series -- what elements to select from the table
|
||||
return $ EventBlock $ \table -> concat (take n (permutations table))
|
||||
return $ InputBlocksUsingTable $ \table -> concat (take n (permutations table))
|
||||
|
||||
verify_simple_input_block_to_event :: Property IO
|
||||
verify_simple_input_block_to_event = forAll $ \(EventBlock block_gen) -> do
|
||||
let simple_input_seq = block_gen simple_chars
|
||||
input = Bytes $ concat [s | (s,_) <- simple_input_seq]
|
||||
events = [e | (_,(k,ms)) <- simple_input_seq, let e = EvKey k ms]
|
||||
verify_simple_input_block_to_event = forAll $ \(InputBlocksUsingTable gen) -> do
|
||||
let input_seq = gen simple_chars
|
||||
input = Bytes $ concat [s | (s,_) <- input_seq]
|
||||
events = [e | (_,(k,ms)) <- input_seq, let e = EvKey k ms]
|
||||
monadic $ assert_events_from_input_block simple_chars [input] events
|
||||
|
||||
verify_keys_from_caps_table_block_to_event :: Property IO
|
||||
verify_keys_from_caps_table_block_to_event = forAll $ \(EventBlock block_gen) ->
|
||||
over (generate (\n -> take n terminals_of_interest)) $ \term_name -> monadic $ do
|
||||
terminal <- setupTerm term_name
|
||||
let table = caps_classify_table terminal keys_from_caps_table
|
||||
input_seq :: [(String, Event)] = block_gen table
|
||||
input_bytes = [Bytes s | (s,_) <- input_seq]
|
||||
input = intersperse (Delay defaultEscDelay) input_bytes
|
||||
events = [e | (_,e) <- input_seq]
|
||||
verify_keys_from_caps_table_block_to_event = forAll $ \(InputBlocksUsingTable gen) ->
|
||||
forEachOf terminals_of_interest $ \term_name -> monadic $ do
|
||||
term <- setupTerm term_name
|
||||
let table = caps_classify_table term keys_from_caps_table
|
||||
input_seq = gen table
|
||||
events = [e | (_,e) <- input_seq]
|
||||
keydowns = [Bytes s | (s,_) <- input_seq]
|
||||
input = intersperse (Delay defaultEscDelay) keydowns
|
||||
assert_events_from_input_block (map_to_legacy_table table) input events
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
[ testProperty "basic block generated from a single ansi chars to event translation"
|
||||
verify_simple_input_block_to_event
|
||||
|
||||
18
vty.cabal
18
vty.cabal
@ -561,6 +561,24 @@ executable vty-interactive-terminal-test
|
||||
utf8-string >= 0.3 && < 0.4,
|
||||
vector >= 0.7
|
||||
|
||||
executable vty-rouge
|
||||
main-is: Rouge.hs
|
||||
hs-source-dirs: test
|
||||
|
||||
default-language: Haskell2010
|
||||
default-extensions: ScopedTypeVariables
|
||||
|
||||
build-depends: vty,
|
||||
base >= 4 && < 5,
|
||||
bytestring,
|
||||
containers,
|
||||
lens,
|
||||
mtl >= 1.1.1.0 && < 2.2,
|
||||
parallel >= 2.2 && < 3.3,
|
||||
text >= 0.11.3,
|
||||
utf8-string >= 0.3 && < 0.4,
|
||||
vector >= 0.7
|
||||
|
||||
executable vty-benchmark
|
||||
main-is: benchmark.hs
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user