Betris.hs

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

import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TBChan
import Control.Lens hiding (argument)
import Control.Monad (forever)
import Control.Monad.STM (atomically)
import Data.Char (chr)
import Data.Foldable (for_)
import qualified Data.Map as Map
import Data.Time.Units
import Data.Version (showVersion)
import Game.Tetris
import Graphics.Vty
import Linear.V2 (V2(..))
import Paths_betris (version)
import Prelude hiding (Left, Right)
import Options.Applicative hiding (command, (<|>))

command :: Parser (IO ())
command = betris <$> (versionOption <*> programOptions)

data Options = Options { initialDelay :: Millisecond } deriving (Eq, Show)

programOptions :: Parser Options
programOptions =
  Options <$> option auto (long "initial-delay" <> metavar "DURATION" <>
                           value (fromMicroseconds 1000000) <> showDefault <>
                           help "Initial delay")

data Event e = Tick | Ev e deriving (Eq, Read, Show, Functor)

betris Options{..} = do
  vty <- mkVty =<< userConfig
  chan <- newTBChanIO 10
  game <- initGame 0
  speed <- newTVarIO $ fromIntegral $ toMicroseconds initialDelay

  forkIO $ forever $ do
    e <- nextEvent vty
    atomically $ writeTBChan chan $ Ev e

  forkIO $ forever $ do
    atomically $ writeTBChan chan Tick
    delay <- readTVarIO speed
    atomically $ modifyTVar speed ((-) 500)
    threadDelay delay

  _ <- play vty chan game
  shutdown vty
  putStrLn ""

play vty chan game
  | isGameOver game = pure $ game ^. score
  | otherwise = do
    update vty $ picForImage $
      string defAttr (emboss game) <|> string defAttr (show $ game ^. score)
    e <- atomically $ readTBChan chan
    case e of
      Ev (EvKey KEsc []) -> pure $ game ^. score
      Tick -> timeStep game >>= play vty chan
      Ev (EvKey KLeft []) -> play vty chan (hardDrop game)
      Ev (EvKey KUp []) -> play vty chan (shift Left game)
      Ev (EvKey KDown []) -> play vty chan (shift Right game)
      Ev (EvKey KEnter []) -> play vty chan (rotate game)
      _ -> play vty chan game

emboss :: Game -> String
emboss g = 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)
  blk b = Map.fromList $ map (, b ^. shape) $ coords b

versionOption :: Parser (a -> a)
versionOption = infoOption (showVersion version) $
    long "version"
 <> help "Show version"