{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module Command.Betris (command, Options(..), betris) where import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM.TChan import Control.Monad (forever) import Control.Monad.STM (atomically) import Data.Char (chr) import Data.IORef import qualified Data.Map as Map import Data.Time.Units import Data.Version (showVersion) import Game.Tetris import Graphics.Vty.Config (userConfig) import Graphics.Vty.Input hiding (Event) import qualified Graphics.Vty.Input as Vty (Event) import Graphics.Vty.Input.Events (InternalEvent (InputEvent)) import Lens.Micro ((^.)) import Linear.V2 (V2 (..), _x) import Options.Applicative hiding (command, (<|>)) import Paths_betris (version) import Prelude hiding (Left, Right) import System.Console.ANSI import System.IO (hFlush, stdout) command :: Parser (IO ()) command :: Parser (IO ()) command = Options -> IO () betris forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (forall a. Parser (a -> a) versionOption forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Options programOptions) newtype Options = Options { Options -> Millisecond initialDelay :: Millisecond } deriving (Options -> Options -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Options -> Options -> Bool $c/= :: Options -> Options -> Bool == :: Options -> Options -> Bool $c== :: Options -> Options -> Bool Eq, Int -> Options -> ShowS [Options] -> ShowS Options -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Options] -> ShowS $cshowList :: [Options] -> ShowS show :: Options -> String $cshow :: Options -> String showsPrec :: Int -> Options -> ShowS $cshowsPrec :: Int -> Options -> ShowS Show) programOptions :: Parser Options programOptions :: Parser Options programOptions = Millisecond -> Options Options forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser Millisecond initialDelayOption data Event e = Tick | Ev e deriving (Event e -> Event e -> Bool forall e. Eq e => Event e -> Event e -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Event e -> Event e -> Bool $c/= :: forall e. Eq e => Event e -> Event e -> Bool == :: Event e -> Event e -> Bool $c== :: forall e. Eq e => Event e -> Event e -> Bool Eq, ReadPrec [Event e] ReadPrec (Event e) ReadS [Event e] forall e. Read e => ReadPrec [Event e] forall e. Read e => ReadPrec (Event e) forall e. Read e => Int -> ReadS (Event e) forall e. Read e => ReadS [Event e] forall a. (Int -> ReadS a) -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a readListPrec :: ReadPrec [Event e] $creadListPrec :: forall e. Read e => ReadPrec [Event e] readPrec :: ReadPrec (Event e) $creadPrec :: forall e. Read e => ReadPrec (Event e) readList :: ReadS [Event e] $creadList :: forall e. Read e => ReadS [Event e] readsPrec :: Int -> ReadS (Event e) $creadsPrec :: forall e. Read e => Int -> ReadS (Event e) Read, Int -> Event e -> ShowS forall e. Show e => Int -> Event e -> ShowS forall e. Show e => [Event e] -> ShowS forall e. Show e => Event e -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Event e] -> ShowS $cshowList :: forall e. Show e => [Event e] -> ShowS show :: Event e -> String $cshow :: forall e. Show e => Event e -> String showsPrec :: Int -> Event e -> ShowS $cshowsPrec :: forall e. Show e => Int -> Event e -> ShowS Show, forall a b. a -> Event b -> Event a forall a b. (a -> b) -> Event a -> Event b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: forall a b. a -> Event b -> Event a $c<$ :: forall a b. a -> Event b -> Event a fmap :: forall a b. (a -> b) -> Event a -> Event b $cfmap :: forall a b. (a -> b) -> Event a -> Event b Functor) betris :: Options -> IO () betris :: Options -> IO () betris Options{Millisecond initialDelay :: Millisecond initialDelay :: Options -> Millisecond ..} = do Input input <- Config -> IO Input inputForConfig forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< IO Config userConfig TChan (Event Event) chan <- forall a. IO (TChan a) newTChanIO Game game <- Int -> IO Game initGame Int 0 IORef Int delay <- forall a. a -> IO (IORef a) newIORef forall a b. (a -> b) -> a -> b $ forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ forall a. TimeUnit a => a -> Integer toMicroseconds Millisecond initialDelay ThreadId _ <- IO () -> IO ThreadId forkIO forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Applicative f => f a -> f b forever forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. STM a -> IO a atomically forall a b. (a -> b) -> a -> b $ forall a. TChan a -> STM a readTChan (Input -> TChan InternalEvent _eventChannel Input input) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case InputEvent Event e -> forall a. TChan a -> a -> STM () writeTChan TChan (Event Event) chan (forall e. e -> Event e Ev Event e) InternalEvent _ -> forall (f :: * -> *) a. Applicative f => a -> f a pure () ThreadId _ <- IO () -> IO ThreadId forkIO forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a b. Applicative f => f a -> f b forever forall a b. (a -> b) -> a -> b $ do forall a. IORef a -> IO a readIORef IORef Int delay forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Int -> IO () threadDelay forall a. IORef a -> (a -> a) -> IO () modifyIORef IORef Int delay (forall a. Num a => a -> a -> a subtract Int 100) forall a. STM a -> IO a atomically forall a b. (a -> b) -> a -> b $ forall a. TChan a -> a -> STM () writeTChan TChan (Event Event) chan forall e. Event e Tick Game _ <- TChan (Event Event) -> Game -> IO Game play TChan (Event Event) chan Game game Input -> IO () shutdownInput Input input String -> IO () putStrLn String "" play :: TChan (Event Vty.Event) -> Game -> IO Game play :: TChan (Event Event) -> Game -> IO Game play TChan (Event Event) chan Game tetris | Game -> Bool isGameOver Game tetris = forall (f :: * -> *) a. Applicative f => a -> f a pure Game tetris | Bool otherwise = do String -> IO () putStr forall a b. (a -> b) -> a -> b $ String "\r" forall a. Semigroup a => a -> a -> a <> Game -> String emboss Game tetris forall a. Semigroup a => a -> a -> a <> String " [" forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> String show (Game tetris forall s a. s -> Getting a s a -> a ^. Lens' Game Int score) forall a. Semigroup a => a -> a -> a <> String "]" forall a. Semigroup a => a -> a -> a <> String clearFromCursorToLineEndCode Handle -> IO () hFlush Handle stdout forall a. STM a -> IO a atomically (forall a. TChan a -> STM a readTChan TChan (Event Event) chan) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Event Event Tick -> TChan (Event Event) -> Game -> IO Game play TChan (Event Event) chan forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Game -> IO Game timeStep Game tetris Ev (EvKey (KChar Char ' ') []) -> TChan (Event Event) -> Game -> IO Game play TChan (Event Event) chan forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Game -> IO Game timeStep Game tetris Ev (EvKey Key KLeft []) -> TChan (Event Event) -> Game -> IO Game play TChan (Event Event) chan forall a b. (a -> b) -> a -> b $ Game -> Game hardDrop Game tetris Ev (EvKey Key KUp []) -> TChan (Event Event) -> Game -> IO Game play TChan (Event Event) chan forall a b. (a -> b) -> a -> b $ Direction Left Direction -> Game -> Game `shift` Game tetris Ev (EvKey Key KDown []) -> TChan (Event Event) -> Game -> IO Game play TChan (Event Event) chan forall a b. (a -> b) -> a -> b $ Direction Right Direction -> Game -> Game `shift` Game tetris Ev (EvKey Key KEnter []) -> TChan (Event Event) -> Game -> IO Game play TChan (Event Event) chan forall a b. (a -> b) -> a -> b $ Game -> Game rotate Game tetris Ev (EvKey Key KEsc []) -> forall (f :: * -> *) a. Applicative f => a -> f a pure Game tetris Event Event _ -> TChan (Event Event) -> Game -> IO Game play TChan (Event Event) chan Game tetris emboss :: Game -> String emboss :: Game -> String emboss Game game = forall a b. (a -> b) -> [a] -> [b] map Int -> Char go [Int 1, Int 3 .. Int boardHeight forall a. Num a => a -> a -> a + Int 6] where go :: Int -> Char go Int y = Int -> Char chr forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (forall {a}. Num a => Int -> ((Int, Int), a) -> a -> a f Int y) Int 0x2800 [((Int 0,Int 0),Int 1), ((Int 1,Int 0), Int 2), ((Int 2,Int 0), Int 4) ,((Int 0,Int 1),Int 8), ((Int 1,Int 1),Int 16), ((Int 2,Int 1),Int 32) ,((Int 3,Int 0),Int 64),((Int 3,Int 1),Int 128)] f :: Int -> ((Int, Int), a) -> a -> a f Int y ((Int x',Int y'), a v) a a = case forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup (forall a. a -> a -> V2 a V2 (Int xforall a. Num a => a -> a -> a +Int x') (Int yforall a. Num a => a -> a -> a +Int y')) Board fullBoard of Just Tetrimino _ -> a a forall a. Num a => a -> a -> a + a v Maybe Tetrimino _ -> a a minx :: Block -> Int minx Block b = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a minimum forall a b. (a -> b) -> a -> b $ (Int boardWidth forall a. Num a => a -> a -> a - Int 3) forall a. a -> [a] -> [a] : forall a b. (a -> b) -> [a] -> [b] map (forall s a. s -> Getting a s a -> a ^. forall (t :: * -> *) a. R1 t => Lens' (t a) a _x) (Block -> [V2 Int] coords Block b) x :: Int x = Block -> Int minx (Game game forall s a. s -> Getting a s a -> a ^. Lens' Game Block block) fullBoard :: Board fullBoard = Game game forall s a. s -> Getting a s a -> a ^. Lens' Game Board board forall a. Semigroup a => a -> a -> a <> Block -> Board blk (Game game forall s a. s -> Getting a s a -> a ^. Lens' Game Block block) forall a. Semigroup a => a -> a -> a <> Block -> Board blk Block next next :: Block next = let b :: Block b = Tetrimino -> Block initBlock (Game game forall s a. s -> Getting a s a -> a ^. Lens' Game Tetrimino nextShape) in forall s. Translatable s => Int -> Direction -> s -> s translateBy (-Int 4) Direction Down forall a b. (a -> b) -> a -> b $ forall s. Translatable s => Int -> Direction -> s -> s translateBy (Int x forall a. Num a => a -> a -> a - Block -> Int minx Block b) Direction Right Block b blk :: Block -> Board blk Block b = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (, Block b forall s a. s -> Getting a s a -> a ^. Lens' Block Tetrimino shape) forall a b. (a -> b) -> a -> b $ Block -> [V2 Int] coords Block b initialDelayOption :: Parser Millisecond initialDelayOption :: Parser Millisecond initialDelayOption = forall a. ReadM a -> Mod OptionFields a -> Parser a option forall a. Read a => ReadM a auto forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. HasName f => String -> Mod f a long String "initial-delay" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasName f => Char -> Mod f a short Char 'i' forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a metavar String "DURATION" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. HasValue f => a -> Mod f a value (forall a. TimeUnit a => Integer -> a fromMicroseconds Integer 1500000) forall a. Semigroup a => a -> a -> a <> forall a (f :: * -> *). Show a => Mod f a showDefault forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. String -> Mod f a help String "Initial delay" versionOption :: Parser (a -> a) versionOption :: forall a. Parser (a -> a) versionOption = forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a) infoOption (Version -> String showVersion Version version) forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. HasName f => String -> Mod f a long String "version" forall a. Semigroup a => a -> a -> a <> forall (f :: * -> *) a. String -> Mod f a help String "Show version"