betris 0.1.0.2 → 0.1.1.0

raw patch · 4 files changed

+119/−101 lines, 4 filesdep +time-unitsdep ~basedep ~containersdep ~lensPVP ok

version bump matches the API change (PVP)

Dependencies added: time-units

Dependency ranges changed: base, containers, lens, linear, optparse-applicative, random, stm, stm-chans, vty

API changes (from Hackage documentation)

Files

• app/Main.hs +6/−79
• betris.cabal +24/−21
• src/Command/Betris.hs +88/−0
• src/Game/Tetris.hs +1/−1

@@ -1,82 +1,9 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RecordWildCards #-} module Main where -import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.STM.TVar-import Control.Concurrent.STM.TBChan-import Control.Lens hiding (argument)-import Control.Monad (forever)-import Control.Monad.STM (atomically)-import Data.Char (chr)-import Data.Foldable (for_)-import qualified Data.Map as Map-import Data.Semigroup ((<>))-import Game.Tetris-import Graphics.Vty-import Linear.V2 (V2(..))-import Prelude hiding (Left, Right)-import Options.Applicative hiding ((<|>))--versionOption :: Parser (a -> a)-versionOption = infoOption "0.1.0.2" (long "version" <> help "Show version")--data Options = Options { initialDelay :: Int } deriving Eq--programOptions :: Parser Options-programOptions =-  Options <$> option auto (long "initial-delay" <> metavar "MICROSECONDS" <>-                           value 1000000 <> showDefault <>-                           help "Initial delay")--data Event e = Tick | Ev e deriving (Eq, Read, Show, Functor)--main = do-  Options {..} <- execParser $-    info (helper <*> versionOption <*> programOptions)-         (fullDesc <> progDesc "Braille Tetris")-  vty <- mkVty defaultConfig-  chan <- atomically $ newTBChan 10-  game <- initGame 0-  speed <- newTVarIO initialDelay--  forkIO $ forever $ do-    e <- nextEvent vty-    atomically $ writeTBChan chan $ Ev e--  forkIO $ forever $ do-    atomically $ writeTBChan chan Tick-    delay <- readTVarIO speed-    atomically $ modifyTVar speed ((-) 100)-    threadDelay delay--  consume vty chan game--  shutdown vty--consume vty chan game = if isGameOver game then pure () else do-  update vty $ picForImage $-   string defAttr (emboss game) <|> string defAttr (show $ game ^. score)-  e <- atomically $ readTBChan chan-  case e of-    Ev (EvKey KEsc []) -> pure ()-    Tick -> timeStep game >>= consume vty chan-    Ev (EvKey KLeft []) -> consume vty chan (hardDrop game)-    Ev (EvKey KUp []) -> consume vty chan (shift Left game)-    Ev (EvKey KDown []) -> consume vty chan (shift Right game)-    Ev (EvKey KEnter []) -> consume vty chan (rotate game)-    _ -> consume vty chan game+import qualified Command.Betris as Betris+import Control.Monad (join)+import Options.Applicative -emboss :: Game -> String-emboss g = map go [1, 3 .. boardHeight] where-  go y = chr $ foldr (f y) 0x2800 [((0,0),1), ((1,0), 2), ((2,0), 4)-                                  ,((0,1),8), ((1,1),16), ((2,1),32)-                                  ,((3,0),64),((3,1),128)]-  f y ((x',y'), v) a = case Map.lookup (V2 (x+x') (y+y')) fullBoard of-    Just _ -> a + v-    _ -> a-  x = minimum $ (boardWidth - 3) : map (\(V2 x _) -> x) (coords $ g ^. block)-  fullBoard = g ^. board <> blk (g ^. block)-  blk b = Map.fromList $ map (, b ^. shape) $ coords b+main = join $ execParser $ info (helper <*> Betris.command) $+    fullDesc+ <> progDesc "Braille Tetris"

@@ -2,11 +2,11 @@ -- -- see: https://github.com/sol/hpack ----- hash: 5360efc32ccffdd515059c6e1e560a8654006da8d9f4bf594d7712a8f739cd92+-- hash: fe3279b316adac9c02a50ad90f46dd1800c4189084639dd9ff3b91c81847dc20  name:           betris-version:        0.1.0.2-synopsis:       Braille friendly horizontal version of tetris+version:        0.1.1.0+synopsis:       A horizontal version of tetris for braille users description:    Please see the README at <https://github.com/mlang/betris#readme> category:       Game homepage:       https://github.com/mlang/betris#readme@@ -27,21 +27,23 @@  library   exposed-modules:+      Command.Betris       Game.Tetris   other-modules:       Paths_betris   hs-source-dirs:       src   build-depends:-      base >=4.7 && <5-    , containers-    , lens-    , linear-    , optparse-applicative-    , random-    , stm-    , stm-chans-    , vty+      base >=4.11.0 && <4.12+    , containers >=0.5.7 && <0.6+    , lens >=4.16.0 && <4.17+    , linear >=1.20.7 && <1.21+    , optparse-applicative >=0.14.2 && <0.15+    , random >=1.1 && <1.2+    , stm >=2.4.5 && <2.5+    , stm-chans >=3.0.0 && <3.1+    , time-units >=1.0.0 && <1.1+    , vty >=5.21 && <5.24   default-language: Haskell2010  executable betris@@ -52,14 +54,15 @@       app   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:-      base >=4.7 && <5+      base >=4.11.0 && <4.12     , betris-    , containers-    , lens-    , linear-    , optparse-applicative-    , random-    , stm-    , stm-chans-    , vty+    , containers >=0.5.7 && <0.6+    , lens >=4.16.0 && <4.17+    , linear >=1.20.7 && <1.21+    , optparse-applicative >=0.14.2 && <0.15+    , random >=1.1 && <1.2+    , stm >=2.4.5 && <2.5+    , stm-chans >=3.0.0 && <3.1+    , time-units >=1.0.0 && <1.1+    , vty >=5.21 && <5.24   default-language: Haskell2010

@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-}+module Command.Betris (command, Options(..), betris) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TBChan+import Control.Lens hiding (argument)+import Control.Monad (forever)+import Control.Monad.STM (atomically)+import Data.Char (chr)+import Data.Foldable (for_)+import qualified Data.Map as Map+import Data.Time.Units+import Data.Version (showVersion)+import Game.Tetris+import Graphics.Vty+import Linear.V2 (V2(..))+import Paths_betris (version)+import Prelude hiding (Left, Right)+import Options.Applicative hiding (command, (<|>))++command :: Parser (IO ())+command = betris <$> (versionOption <*> programOptions)++data Options = Options { initialDelay :: Millisecond } deriving (Eq, Show)++programOptions :: Parser Options+programOptions =+  Options <$> option auto (long "initial-delay" <> metavar "DURATION" <>+                           value (fromMicroseconds 1000000) <> showDefault <>+                           help "Initial delay")++data Event e = Tick | Ev e deriving (Eq, Read, Show, Functor)++betris Options{..} = do+  vty <- mkVty =<< userConfig+  chan <- newTBChanIO 10+  game <- initGame 0+  speed <- newTVarIO $ fromIntegral $ toMicroseconds initialDelay++  forkIO $ forever $ do+    e <- nextEvent vty+    atomically $ writeTBChan chan $ Ev e++  forkIO $ forever $ do+    atomically $ writeTBChan chan Tick+    delay <- readTVarIO speed+    atomically $ modifyTVar speed ((-) 500)+    threadDelay delay++  _ <- play vty chan game+  shutdown vty+  putStrLn ""++play vty chan game+  | isGameOver game = pure $ game ^. score+  | otherwise = do+    update vty $ picForImage $+      string defAttr (emboss game) <|> string defAttr (show $ game ^. score)+    e <- atomically $ readTBChan chan+    case e of+      Ev (EvKey KEsc []) -> pure $ game ^. score+      Tick -> timeStep game >>= play vty chan+      Ev (EvKey KLeft []) -> play vty chan (hardDrop game)+      Ev (EvKey KUp []) -> play vty chan (shift Left game)+      Ev (EvKey KDown []) -> play vty chan (shift Right game)+      Ev (EvKey KEnter []) -> play vty chan (rotate game)+      _ -> play vty chan game++emboss :: Game -> String+emboss g = map go [1, 3 .. boardHeight] where+  go y = chr $ foldr (f y) 0x2800 [((0,0),1), ((1,0), 2), ((2,0), 4)+                                  ,((0,1),8), ((1,1),16), ((2,1),32)+                                  ,((3,0),64),((3,1),128)]+  f y ((x',y'), v) a = case Map.lookup (V2 (x+x') (y+y')) fullBoard of+    Just _ -> a + v+    _ -> a+  x = minimum $ (boardWidth - 3) : map (\(V2 x _) -> x) (coords $ g ^. block)+  fullBoard = g ^. board <> blk (g ^. block)+  blk b = Map.fromList $ map (, b ^. shape) $ coords b++versionOption :: Parser (a -> a)+versionOption = infoOption (showVersion version) $+    long "version"+ <> help "Show version"

@@ -143,7 +143,7 @@   where     go (t :< ts) = pure (t, ts)     go EmptyL = freshList >>= bagFourTetriminoEach-    freshList = shuffle . Seq.fromList . take 28 . cycle $ [I ..]+    freshList = shuffle . Seq.fromList . take 28 . cycle $ [(I)..]  -- | Initialize a game with a given level initGame :: Int ->  IO Game