betris 0.1.1.1 → 0.2.0.0
raw patch · 4 files changed
+71/−60 lines, 4 filesdep +ansi-terminaldep ~basedep ~containersdep ~lensPVP ok
version bump matches the API change (PVP)
Dependencies added: ansi-terminal
Dependency ranges changed: base, containers, lens, stm, vty
API changes (from Hackage documentation)
- Command.Betris: data Options
+ Command.Betris: newtype Options
Files
- app/Main.hs +1/−0
- betris.cabal +20/−15
- src/Command/Betris.hs +32/−26
- src/Game/Tetris.hs +18/−19
app/Main.hs view
@@ -5,6 +5,7 @@ import Data.Semigroup ((<>)) import Options.Applicative +main :: IO () main = join $ execParser $ info (helper <*> Betris.command) $ fullDesc <> progDesc "Braille Tetris"
betris.cabal view
@@ -1,11 +1,13 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack ----- hash: a79ba4c668b7653cb2397c625f1a7eaee37bee3eb6e1a2744a64ac110d153fe7+-- hash: 507e72cc3846b3370a9756e6fefd69c3d026964cef52a4f2ea2a2ced50975744 name: betris-version: 0.1.1.1+version: 0.2.0.0 synopsis: A horizontal version of tetris for braille users description: The game of tetris for braille display users, implemented using unicode braille rotated 90 degrees. Tetriminos are "falling" from right to left. category: Game@@ -16,8 +18,8 @@ copyright: 2018 Mario Lang license: BSD3 license-file: LICENSE+tested-with: GHC == 8.0.1, GHC == 8.4.3 build-type: Simple-cabal-version: >= 1.10 extra-source-files: README.md @@ -33,16 +35,18 @@ Paths_betris hs-source-dirs: src+ ghc-options: -Wall build-depends:- base >=4.9.0 && <4.12- , containers >=0.5.7 && <0.6- , lens >=4.15.4 && <4.17+ ansi-terminal+ , base >=4.9.0 && <4.13+ , containers >=0.5.7 && <0.7+ , lens >=4.15.4 && <4.18 , 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 >=2.4.5 && <2.6 , time-units >=1.0.0 && <1.1- , vty >=5.21 && <5.24+ , vty >=5.21 && <5.26 default-language: Haskell2010 executable betris@@ -51,16 +55,17 @@ Paths_betris hs-source-dirs: app- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends:- base >=4.9.0 && <4.12+ ansi-terminal+ , base >=4.9.0 && <4.13 , betris- , containers >=0.5.7 && <0.6- , lens >=4.15.4 && <4.17+ , containers >=0.5.7 && <0.7+ , lens >=4.15.4 && <4.18 , 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 >=2.4.5 && <2.6 , time-units >=1.0.0 && <1.1- , vty >=5.21 && <5.24+ , vty >=5.21 && <5.26 default-language: Haskell2010
src/Command/Betris.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} module Command.Betris (command, Options(..), betris) where@@ -10,24 +11,26 @@ import Control.Monad (forever) import Control.Monad.STM (atomically) import Data.Char (chr)-import Data.Foldable (for_) import Data.IORef import qualified Data.Map as Map import Data.Semigroup ((<>)) import Data.Time.Units import Data.Version (showVersion) import Game.Tetris-import Graphics.Vty hiding (Event)-import qualified Graphics.Vty as Vty (Event)-import Linear.V2 (V2(..))+import Graphics.Vty.Config (userConfig)+import Graphics.Vty.Input hiding (Event)+import qualified Graphics.Vty.Input as Vty (Event)+import Linear.V2 (V2(..), _x) import Paths_betris (version) import Prelude hiding (Left, Right) import Options.Applicative hiding (command, (<|>))+import System.Console.ANSI+import System.IO (hFlush, stdout) command :: Parser (IO ()) command = betris <$> (versionOption <*> programOptions) -data Options = Options { initialDelay :: Millisecond } deriving (Eq, Show)+newtype Options = Options { initialDelay :: Millisecond } deriving (Eq, Show) programOptions :: Parser Options programOptions = Options <$> initialDelayOption@@ -36,47 +39,50 @@ betris :: Options -> IO () betris Options{..} = do- vty <- mkVty =<< userConfig+ input <- inputForConfig =<< userConfig chan <- newTChanIO game <- initGame 0 speed <- newIORef $ fromIntegral $ toMicroseconds initialDelay - forkIO $ forever $ nextEvent vty >>= atomically . writeTChan chan . Ev- forkIO $ forever $ do+ _ <- forkIO . forever . atomically $+ readTChan (_eventChannel input) >>= writeTChan chan . Ev+ _ <- forkIO $ forever $ do readIORef speed >>= threadDelay- modifyIORef speed ((-) 500)+ modifyIORef speed (subtract 500) atomically $ writeTChan chan Tick - _ <- play vty chan game- shutdown vty+ _ <- play chan game+ shutdownInput input putStrLn "" -play :: Vty -> TChan (Event Vty.Event) -> Game -> IO Game-play vty chan tetris+play :: TChan (Event Vty.Event) -> Game -> IO Game+play chan tetris | isGameOver tetris = pure tetris | otherwise = do- update vty $ picForImage $- string defAttr (emboss tetris) <|> string defAttr (show $ tetris ^. score)- e <- atomically $ readTChan chan- case e of- Tick -> play vty chan =<< timeStep tetris- Ev (EvKey KLeft []) -> play vty chan $ hardDrop tetris- Ev (EvKey KUp []) -> play vty chan $ Left `shift` tetris- Ev (EvKey KDown []) -> play vty chan $ Right `shift` tetris- Ev (EvKey KEnter []) -> play vty chan $ rotate tetris+ putStr $ "\r"+ <> emboss tetris+ <> " [" <> show (tetris ^. score) <> "]"+ <> clearFromCursorToLineEndCode+ hFlush stdout+ atomically (readTChan chan) >>= \case+ Tick -> play chan =<< timeStep tetris+ Ev (EvKey KLeft []) -> play chan $ hardDrop tetris+ Ev (EvKey KUp []) -> play chan $ Left `shift` tetris+ Ev (EvKey KDown []) -> play chan $ Right `shift` tetris+ Ev (EvKey KEnter []) -> play chan $ rotate tetris Ev (EvKey KEsc []) -> pure tetris- _ -> play vty chan tetris+ _ -> play chan tetris emboss :: Game -> String-emboss g = map go [1, 3 .. boardHeight] where+emboss game = 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)+ x = minimum $ (boardWidth - 3) : map (^. _x) (coords $ game ^. block)+ fullBoard = game ^. board <> blk (game ^. block) blk b = Map.fromList $ map (, b ^. shape) $ coords b initialDelayOption :: Parser Millisecond
src/Game/Tetris.hs view
@@ -20,19 +20,18 @@ , board, shape, score, block, coords ) where +import Control.Lens hiding ((:<), (<|), (|>), (:>))+import Data.Bool (bool) import Data.Map (Map) import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Monoid (First(..)) import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>), (><)) import qualified Data.Sequence as Seq-import Control.Lens hiding ((:<), (<|), (|>), (:>)) import Linear.V2 (V2(..), _x, _y) import qualified Linear.V2 as LV-import System.Random (getStdRandom, randomR)- import Prelude hiding (Left, Right)-import Data.Bool (bool)-import Data.Maybe (fromMaybe)-import Data.Monoid (First(..))+import System.Random (getStdRandom, randomR) -- Types and instances @@ -125,8 +124,8 @@ where rotateWith :: (Coord -> Coord) -> Block rotateWith dir = b & extra %~ fmap dir- clockwise = (+ o) . (cwperp) . (subtract o)- counterclockwise = (+ o) . LV.perp . (subtract o)+ clockwise = (+ o) . cwperp . subtract o+ counterclockwise = (+ o) . LV.perp . subtract o cwperp (V2 x y) = V2 y (-x) -- | Get coordinates of entire block@@ -143,7 +142,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@@ -171,7 +170,7 @@ -- TODO check if mapKeysMonotonic works clearFullRows :: Game -> Game clearFullRows g = g & board %~ clearBoard- & rowClears %~ (addToRowClears rowCount)+ & rowClears %~ addToRowClears rowCount where clearBoard = M.mapKeys shiftCoordAbove . M.filterWithKey notInFullRow notInFullRow (V2 _ y) _ = y `notElem` fullRowIndices@@ -192,11 +191,11 @@ updateScore g = g & score %~ (+ newPoints) where newPoints = (1 + g ^. level) * (g ^. rowClears ^. to latestOrZero ^. to points)- points 0 = 0- points 1 = 40- points 2 = 100- points 3 = 300- points n = 800+ points 0 = 0+ points 1 = 40+ points 2 = 100+ points 3 = 300+ points _ = 800 -- | Empties row on 0, otherwise appends value (just keeps consecutive information) addToRowClears :: Int -> Seq.Seq Int -> Seq.Seq Int@@ -227,7 +226,7 @@ -- | Check if a block on a board is stopped from further gravitation isStopped :: Board -> Block -> Bool isStopped brd = any cStopped . coords- where cStopped = (||) <$> inRow1 <*> (`M.member` brd) . (translate Down)+ where cStopped = (||) <$> inRow1 <*> (`M.member` brd) . translate Down inRow1 (V2 _ y) = y == 1 hardDrop :: Game -> Game@@ -235,7 +234,7 @@ hardDroppedBlock :: Game -> Block hardDroppedBlock g = translateBy n Down $ g ^. block- where n = minimum $ (subtract 1) <$> (minY : diffs)+ where n = minimum $ subtract 1 <$> (minY : diffs) diffs = [y - yo | (V2 xo yo) <- brdCs, (V2 x y) <- blkCs, xo == x, yo < y] brdCs = g ^. board ^. to M.keys blkCs = g ^. block ^. to coords@@ -243,9 +242,9 @@ -- | Freeze current block freezeBlock :: Game -> Game-freezeBlock g = g & board %~ (M.union blkMap)+freezeBlock g = g & board %~ M.union blkMap where blk = g ^. block- blkMap = M.fromList $ [(c, blk ^. shape) | c <- blk ^. to coords]+ blkMap = M.fromList [(c, blk ^. shape) | c <- blk ^. to coords] -- | Replace block with next block nextBlock :: Game -> IO Game