diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -5,6 +5,7 @@ import Data.Semigroup ((<>)) import Options.Applicative +main :: IO () main = join $ execParser $ info (helper <*> Betris.command) $ fullDesc <> progDesc "Braille Tetris" diff --git a/betris.cabal b/betris.cabal --- a/betris.cabal +++ b/betris.cabal @@ -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 diff --git a/src/Command/Betris.hs b/src/Command/Betris.hs --- a/src/Command/Betris.hs +++ b/src/Command/Betris.hs @@ -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 diff --git a/src/Game/Tetris.hs b/src/Game/Tetris.hs --- a/src/Game/Tetris.hs +++ b/src/Game/Tetris.hs @@ -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