{-# 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"