{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}
module Command.Betris (command, Options(..), betris) where

import Prelude hiding (Left, Right)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM.TChan
import Control.Lens hiding (argument)
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 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 :: Parser (IO ())
command = Options -> IO ()
betris (Options -> IO ()) -> Parser Options -> Parser (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser (Options -> Options)
forall a. Parser (a -> a)
versionOption Parser (Options -> Options) -> Parser Options -> Parser Options
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
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
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
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
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 (Millisecond -> Options) -> Parser Millisecond -> Parser 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
(Event e -> Event e -> Bool)
-> (Event e -> Event e -> Bool) -> Eq (Event e)
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)
Int -> ReadS (Event e)
ReadS [Event e]
(Int -> ReadS (Event e))
-> ReadS [Event e]
-> ReadPrec (Event e)
-> ReadPrec [Event e]
-> Read (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
[Event e] -> ShowS
Event e -> String
(Int -> Event e -> ShowS)
-> (Event e -> String) -> ([Event e] -> ShowS) -> Show (Event e)
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, a -> Event b -> Event a
(a -> b) -> Event a -> Event b
(forall a b. (a -> b) -> Event a -> Event b)
-> (forall a b. a -> Event b -> Event a) -> Functor Event
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
<$ :: a -> Event b -> Event a
$c<$ :: forall a b. a -> Event b -> Event a
fmap :: (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 (Config -> IO Input) -> IO Config -> IO Input
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Config
userConfig
  TChan (Event Event)
chan <- IO (TChan (Event Event))
forall a. IO (TChan a)
newTChanIO
  Game
game <- Int -> IO Game
initGame Int
0
  IORef Int
delay <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int -> IO (IORef Int)) -> Int -> IO (IORef Int)
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Millisecond -> Integer
forall a. TimeUnit a => a -> Integer
toMicroseconds Millisecond
initialDelay

  ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId)
-> (STM () -> IO ()) -> STM () -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> (STM () -> IO ()) -> STM () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ThreadId) -> STM () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
    TChan Event -> STM Event
forall a. TChan a -> STM a
readTChan (Input -> TChan Event
_eventChannel Input
input) STM Event -> (Event -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TChan (Event Event) -> Event Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (Event Event)
chan (Event Event -> STM ())
-> (Event -> Event Event) -> Event -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Event Event
forall e. e -> Event e
Ev
  ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
delay IO Int -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO ()
threadDelay
    IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Int
delay (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
100)
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan (Event Event) -> Event Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (Event Event)
chan Event Event
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 = Game -> IO Game
forall (f :: * -> *) a. Applicative f => a -> f a
pure Game
tetris
  | Bool
otherwise = do
    String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\r"
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Game -> String
emboss Game
tetris
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" [" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Game
tetris Game -> Getting Int Game Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Game Int
Lens' Game Int
score) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]"
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
clearFromCursorToLineEndCode
    Handle -> IO ()
hFlush Handle
stdout
    STM (Event Event) -> IO (Event Event)
forall a. STM a -> IO a
atomically (TChan (Event Event) -> STM (Event Event)
forall a. TChan a -> STM a
readTChan TChan (Event Event)
chan) IO (Event Event) -> (Event Event -> IO Game) -> IO Game
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 (Game -> IO Game) -> IO Game -> IO Game
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 (Game -> IO Game) -> IO Game -> IO Game
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 (Game -> IO Game) -> Game -> IO Game
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 (Game -> IO Game) -> Game -> IO Game
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 (Game -> IO Game) -> Game -> IO Game
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 (Game -> IO Game) -> Game -> IO Game
forall a b. (a -> b) -> a -> b
$ Game -> Game
rotate Game
tetris
      Ev (EvKey Key
KEsc [])   -> Game -> IO Game
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 = (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
go [Int
1, Int
3 .. Int
boardHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6] where
  go :: Int -> Char
go Int
y = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ (((Int, Int), Int) -> Int -> Int)
-> Int -> [((Int, Int), Int)] -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> ((Int, Int), Int) -> Int -> Int
forall p. Num p => Int -> ((Int, Int), p) -> p -> p
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), p) -> p -> p
f Int
y ((Int
x',Int
y'), p
v) p
a = case V2 Int -> Map (V2 Int) Tetrimino -> Maybe Tetrimino
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
x') (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
y')) Map (V2 Int) Tetrimino
fullBoard of
    Just Tetrimino
_ -> p
a p -> p -> p
forall a. Num a => a -> a -> a
+ p
v
    Maybe Tetrimino
_ -> p
a
  minx :: Block -> Int
minx Block
b = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int
boardWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (V2 Int -> Int) -> [V2 Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (V2 Int -> Getting Int (V2 Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (V2 Int) Int
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) (Block -> [V2 Int]
coords Block
b)
  x :: Int
x = Block -> Int
minx (Game
game Game -> Getting Block Game Block -> Block
forall s a. s -> Getting a s a -> a
^. Getting Block Game Block
Lens' Game Block
block)
  fullBoard :: Map (V2 Int) Tetrimino
fullBoard = Game
game Game
-> Getting (Map (V2 Int) Tetrimino) Game (Map (V2 Int) Tetrimino)
-> Map (V2 Int) Tetrimino
forall s a. s -> Getting a s a -> a
^. Getting (Map (V2 Int) Tetrimino) Game (Map (V2 Int) Tetrimino)
Lens' Game (Map (V2 Int) Tetrimino)
board Map (V2 Int) Tetrimino
-> Map (V2 Int) Tetrimino -> Map (V2 Int) Tetrimino
forall a. Semigroup a => a -> a -> a
<> Block -> Map (V2 Int) Tetrimino
blk (Game
game Game -> Getting Block Game Block -> Block
forall s a. s -> Getting a s a -> a
^. Getting Block Game Block
Lens' Game Block
block) Map (V2 Int) Tetrimino
-> Map (V2 Int) Tetrimino -> Map (V2 Int) Tetrimino
forall a. Semigroup a => a -> a -> a
<> Block -> Map (V2 Int) Tetrimino
blk Block
next
  next :: Block
next = let b :: Block
b = Tetrimino -> Block
initBlock (Game
game Game -> Getting Tetrimino Game Tetrimino -> Tetrimino
forall s a. s -> Getting a s a -> a
^. Getting Tetrimino Game Tetrimino
Lens' Game Tetrimino
nextShape) in
         Int -> Direction -> Block -> Block
forall s. Translatable s => Int -> Direction -> s -> s
translateBy (-Int
4) Direction
Down (Block -> Block) -> Block -> Block
forall a b. (a -> b) -> a -> b
$ Int -> Direction -> Block -> Block
forall s. Translatable s => Int -> Direction -> s -> s
translateBy (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Block -> Int
minx Block
b) Direction
Right Block
b
  blk :: Block -> Map (V2 Int) Tetrimino
blk Block
b = [(V2 Int, Tetrimino)] -> Map (V2 Int) Tetrimino
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(V2 Int, Tetrimino)] -> Map (V2 Int) Tetrimino)
-> [(V2 Int, Tetrimino)] -> Map (V2 Int) Tetrimino
forall a b. (a -> b) -> a -> b
$ (V2 Int -> (V2 Int, Tetrimino))
-> [V2 Int] -> [(V2 Int, Tetrimino)]
forall a b. (a -> b) -> [a] -> [b]
map (, Block
b Block -> Getting Tetrimino Block Tetrimino -> Tetrimino
forall s a. s -> Getting a s a -> a
^. Getting Tetrimino Block Tetrimino
Lens' Block Tetrimino
shape) ([V2 Int] -> [(V2 Int, Tetrimino)])
-> [V2 Int] -> [(V2 Int, Tetrimino)]
forall a b. (a -> b) -> a -> b
$ Block -> [V2 Int]
coords Block
b

initialDelayOption :: Parser Millisecond
initialDelayOption :: Parser Millisecond
initialDelayOption = ReadM Millisecond
-> Mod OptionFields Millisecond -> Parser Millisecond
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Millisecond
forall a. Read a => ReadM a
auto (Mod OptionFields Millisecond -> Parser Millisecond)
-> Mod OptionFields Millisecond -> Parser Millisecond
forall a b. (a -> b) -> a -> b
$
    String -> Mod OptionFields Millisecond
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"initial-delay"
 Mod OptionFields Millisecond
-> Mod OptionFields Millisecond -> Mod OptionFields Millisecond
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Millisecond
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'i'
 Mod OptionFields Millisecond
-> Mod OptionFields Millisecond -> Mod OptionFields Millisecond
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Millisecond
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"DURATION"
 Mod OptionFields Millisecond
-> Mod OptionFields Millisecond -> Mod OptionFields Millisecond
forall a. Semigroup a => a -> a -> a
<> Millisecond -> Mod OptionFields Millisecond
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value (Integer -> Millisecond
forall a. TimeUnit a => Integer -> a
fromMicroseconds Integer
1500000)
 Mod OptionFields Millisecond
-> Mod OptionFields Millisecond -> Mod OptionFields Millisecond
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields Millisecond
forall a (f :: * -> *). Show a => Mod f a
showDefault
 Mod OptionFields Millisecond
-> Mod OptionFields Millisecond -> Mod OptionFields Millisecond
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Millisecond
forall (f :: * -> *) a. String -> Mod f a
help String
"Initial delay"

versionOption :: Parser (a -> a)
versionOption :: Parser (a -> a)
versionOption = String -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption (Version -> String
showVersion Version
version) (Mod OptionFields (a -> a) -> Parser (a -> a))
-> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a b. (a -> b) -> a -> b
$
    String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"version"
 Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. String -> Mod f a
help String
"Show version"