make the start of a silly rouge like game

test/Rouge.hs

@@ -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

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

test/VerifyUsingMockInput.hs

@@ -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
+instance Show (InputBlocksUsingTable event) where
-    show (EventBlock g) = "EventBlock(*->*)"
+    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
+verify_simple_input_block_to_event = forAll $ \(InputBlocksUsingTable gen) -> do
-    let simple_input_seq = block_gen simple_chars
+    let input_seq = gen simple_chars
-        input = Bytes $ concat [s | (s,_) <- simple_input_seq]
+        input     = Bytes $ concat [s | (s,_) <- input_seq]
-        events = [e | (_,(k,ms)) <- simple_input_seq, let e = EvKey k ms]
+        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) ->
+verify_keys_from_caps_table_block_to_event = forAll $ \(InputBlocksUsingTable gen) ->
-    over (generate (\n -> take n terminals_of_interest)) $ \term_name -> monadic $ do
+    forEachOf terminals_of_interest $ \term_name -> monadic $ do
-        terminal <- setupTerm term_name
+        term <- setupTerm term_name
-        let table = caps_classify_table terminal keys_from_caps_table
+        let table         = caps_classify_table term keys_from_caps_table
-            input_seq :: [(String, Event)] = block_gen table
+            input_seq     = gen table
-            input_bytes = [Bytes s | (s,_) <- input_seq]
-            input = intersperse (Delay defaultEscDelay) input_bytes
             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

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