aadit/tetris-cli
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Refactor game state computation

Browse source 
Cleaning up the Tetris module, mainly to favor a MonadState style over
explicit `Game -> Game` functions, which were a little awkward. This also
led naturally to explicitly isolating `IO`, by having pure state modifiers
with types like `Tetris a ~ forall m. StateT Game m a` being executed
with `m ~ Identity`, and those few modifiers that need IO specified by
`TetrisT a ~ StateT Game IO a`.
This commit is contained in:
Sam Tay 2018-12-27 10:28:26 -05:00
parent 09de01695c
commit ad1fcf9192
6 changed files with 179 additions and 157 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

@ -1,6 +1,6 @@
*.swp *.swp
*.swo *.swo
tags
dist dist
dist-* dist-*
cabal-dev cabal-dev

9
app/Main.hs
View file

@ -7,14 +7,13 @@ import System.Exit (exitSuccess)
import System.IO (readFile, writeFile) import System.IO (readFile, writeFile)
import Text.Read (readMaybe) import Text.Read (readMaybe)
import Tetris (Game(..))
import UI.PickLevel (pickLevel)
import UI.Game (playGame)
import Options.Applicative import Options.Applicative
import qualified System.Directory as D import qualified System.Directory as D
import System.FilePath ((</>)) import System.FilePath ((</>))
import qualified System.FilePath as F
import Tetris (Game(..))
import UI.PickLevel (pickLevel)
import UI.Game (playGame)
data Opts = Opts data Opts = Opts
{ hardDrop :: Maybe HardDropOpt { hardDrop :: Maybe HardDropOpt

239
src/Tetris.hs
View file

@ -1,5 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Tetris module Tetris
( (
-- Game state modifiers -- Game state modifiers
@ -8,38 +10,40 @@ module Tetris
, shift , shift
, rotate , rotate
, hardDrop , hardDrop
-- Game state handlers
, execTetris
, evalTetris
-- Game state queries -- Game state queries
, isGameOver , isGameOver
, hardDroppedBlock , hardDroppedBlock
, coords , coords
-- Types -- Types
, Block(..) , Block(..)
, Coord(..) , Coord
, Direction(..) , Direction(..)
, Game(..) , Game(..)
, Tetrimino(..) , Tetrimino(..)
, Tetris
-- Lenses -- Lenses
, block, board, level, nextShape, score, shape , block, board, level, nextShape, score, shape
-- Constants -- Constants
, boardHeight, boardWidth, relCells , boardHeight, boardWidth, relCells
) where ) where
import Prelude hiding (Left, Right)
import Control.Applicative ((<|>))
import Control.Monad (forM_, mfilter, when, (<=<))
import Control.Monad.IO.Class (MonadIO(..), liftIO)
import Control.Monad.Trans.State (StateT(..), gets, evalStateT, execStateT)
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Sequence (ViewL(..), ViewR(..), (<|), (|>), (><)) import Data.Sequence (Seq(..), (><))
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Lens.Micro import Control.Lens hiding (Empty)
import Lens.Micro.TH import Linear.V2 (V2(..), _y)
import Linear.V2 (V2(..), _x, _y)
import qualified Linear.V2 as LV import qualified Linear.V2 as LV
import System.Random (getStdRandom, randomR) import System.Random (getStdRandom, randomR)
import Prelude hiding (Left, Right)
import Control.Monad (mfilter)
import Data.Bool (bool)
import Data.Maybe (fromMaybe)
import Data.Monoid (First(..))
-- Types and instances -- Types and instances
-- | Tetris shape types -- | Tetris shape types
@ -77,9 +81,17 @@ data Game = Game
, _score :: Int , _score :: Int
, _board :: Board , _board :: Board
} deriving (Eq, Show) } deriving (Eq, Show)
makeLenses ''Game makeLenses ''Game
type TetrisT = StateT Game
type Tetris a = forall m. (Monad m) => TetrisT m a
evalTetris :: Tetris a -> Game -> a
evalTetris m = runIdentity . evalStateT m
execTetris :: Tetris a -> Game -> Game
execTetris m = runIdentity . execStateT m
-- Translate class for direct translations, without concern for boundaries -- Translate class for direct translations, without concern for boundaries
-- 'shift' concerns safe translations with boundaries -- 'shift' concerns safe translations with boundaries
class Translatable s where class Translatable s where
@ -123,8 +135,8 @@ startOrigin = V2 6 22
-- | Rotate block counter clockwise about origin -- | Rotate block counter clockwise about origin
-- *Note*: Strict unsafe rotation not respecting boundaries -- *Note*: Strict unsafe rotation not respecting boundaries
-- Safety can only be assured within Game context -- Safety can only be assured within Game context
rotate' :: Block -> Block rotateRaw :: Block -> Block
rotate' b@(Block s o@(V2 xo yo) cs) rotateRaw b@(Block s o@(V2 xo yo) cs)
| -- O doesn't need rotation | -- O doesn't need rotation
s == O = b s == O = b
| -- I only has two orientations | -- I only has two orientations
@ -146,11 +158,9 @@ coords b = b ^. origin : b ^. extra
-- before next bag (random permutation of 4*each tetrimino) is created. If input is empty, -- before next bag (random permutation of 4*each tetrimino) is created. If input is empty,
-- generates new bag, otherwise just unshifts the first value and returns pair. -- generates new bag, otherwise just unshifts the first value and returns pair.
bagFourTetriminoEach :: Seq.Seq Tetrimino -> IO (Tetrimino, Seq.Seq Tetrimino) bagFourTetriminoEach :: Seq.Seq Tetrimino -> IO (Tetrimino, Seq.Seq Tetrimino)
bagFourTetriminoEach = go . Seq.viewl bagFourTetriminoEach (t :<| ts) = pure (t, ts)
where bagFourTetriminoEach Empty =
go (t :< ts) = pure (t, ts) bagFourTetriminoEach <=< shuffle . Seq.fromList . take 28 $ cycle [(I) ..]
go EmptyL = freshList >>= bagFourTetriminoEach
freshList = shuffle . Seq.fromList . take 28 . cycle $ [(I) ..]
-- | Initialize a game with a given level -- | Initialize a game with a given level
initGame :: Int -> IO Game initGame :: Int -> IO Game
@ -170,127 +180,139 @@ initGame lvl = do
isGameOver :: Game -> Bool isGameOver :: Game -> Bool
isGameOver g = blockStopped g && g ^. block ^. origin == startOrigin isGameOver g = blockStopped g && g ^. block ^. origin == startOrigin
timeStep :: Game -> IO Game -- | The main game execution, this is executed at each discrete time step
timeStep g = if blockStopped g timeStep :: MonadIO m => TetrisT m ()
then nextBlock . updateScore . clearFullRows . freezeBlock $ g timeStep = do
else pure . gravitate $ g gets blockStopped >>= \case
False -> gravitate
True -> do
freezeBlock
cleared <- clearFullRows
addToRowClears cleared
updateScore
nextBlock
-- TODO check if mapKeysMonotonic works -- | Gravitate current block, i.e. shift down
clearFullRows :: Game -> Game gravitate :: Tetris ()
clearFullRows g = gravitate = shift Down
g & board %~ clearBoard
& rowClears %~ (addToRowClears rowCount) -- | If necessary: clear full rows and return the count
where clearFullRows :: Tetris Int
clearBoard = M.mapKeys shiftCoordAbove . M.filterWithKey notInFullRow clearFullRows = do
notInFullRow (V2 _ y) _ = y `notElem` fullRowIndices brd <- use board
rowCount = length fullRowIndices let rowSize r = length $ M.filterWithKey (\(V2 _ y) _ -> r == y) brd
fullRowIndices = filter isFullRow [1 .. boardHeight] fullRows = filter (\r -> boardWidth == rowSize r) [1 .. boardHeight]
isFullRow r = boardWidth == (length . M.filterWithKey (inRow r) $ g ^. board) -- Clear cells in full rows
inRow r (V2 _ y) _ = r == y modifying board $ M.filterWithKey $ \(V2 _ y) _ -> y `notElem` fullRows
shiftCoordAbove (V2 x y) = -- Shift cells above full rows
let offset = length . filter (< y) $ fullRowIndices in V2 x (y - offset) modifying board $ M.mapKeysMonotonic $ over _y $ \y ->
y - (length $ filter (< y) fullRows)
return $ length fullRows
-- | Empties row on 0, otherwise appends value (just keeps consecutive information)
addToRowClears :: Int -> Tetris ()
addToRowClears 0 = rowClears .= mempty
addToRowClears n = rowClears %= (|> n)
-- | This updates game points with respect to the current -- | This updates game points with respect to the current
-- _rowClears value (thus should only be used ONCE per step) -- _rowClears value (thus should only be used ONCE per step)
-- --
-- Note I'm keeping rowClears as a sequence in case I want to award -- Note I'm keeping rowClears as a sequence in case I want to award
-- more points for back to back clears, right now the scoring is more simple -- more points for back to back clears, right now the scoring is more simple,
updateScore :: Game -> Game -- but you do get more points for more rows cleared at once.
updateScore g = g & score %~ (+ newPoints) updateScore :: Tetris ()
updateScore = do
multiplier <- (1 +) <$> use level
clears <- latestOrZero <$> use rowClears
let newPoints = multiplier * points clears
score %= (+ newPoints)
where where
newPoints = -- Translate row clears to points
(1 + g ^. level) * (g ^. rowClears ^. to latestOrZero ^. to points)
points 0 = 0 points 0 = 0
points 1 = 40 points 1 = 40
points 2 = 100 points 2 = 100
points 3 = 300 points 3 = 300
points n = 800 points _ = 800
-- | Get last value of sequence or 0 if empty
-- | Empties row on 0, otherwise appends value (just keeps consecutive information) latestOrZero :: Seq.Seq Int -> Int
addToRowClears :: Int -> Seq.Seq Int -> Seq.Seq Int latestOrZero Empty = 0
addToRowClears 0 _ = mempty latestOrZero (_ :|> n) = n
addToRowClears n rs = rs |> n
-- | Get last value of sequence or 0 if empty
latestOrZero :: Seq.Seq Int -> Int
latestOrZero = go . Seq.viewr
where
go EmptyR = 0
go (_ :> n) = n
-- | Handle counterclockwise block rotation (if possible) -- | Handle counterclockwise block rotation (if possible)
-- Allows wallkicks: http://tetris.wikia.com/wiki/TGM_rotation -- Allows wallkicks: http://tetris.wikia.com/wiki/TGM_rotation
rotate :: Game -> Game rotate :: Tetris ()
rotate g = g & block .~ nextB rotate = do
where blk <- use block
nextB = fromMaybe blk $ getFirst . mconcat $ First <$> bs brd <- use board
bs = map ($ blk) safeFuncs let mblk = foldr (<|>) Nothing
safeFuncs = map (mkSafe .) funcs $ mfilter (isValidBlockPosition brd)
mkSafe = mfilter (isValidBlockPosition brd) . pure . pure
funcs = [rotate', rotate' . translate Left, rotate' . translate Right] . ($ blk)
blk = g ^. block <$> [ rotateRaw
brd = g ^. board , rotateRaw . translate Left
, rotateRaw . translate Right
]
forM_ mblk $ assign block
blockStopped :: Game -> Bool blockStopped :: Game -> Bool
blockStopped g = isStopped (g ^. board) (g ^. block) blockStopped g = isStopped (g ^. board) (g ^. block)
-- | Check if a block on a board is stopped from further gravitation -- | Check if a block on a board is stopped from further gravitation
isStopped :: Board -> Block -> Bool isStopped :: Board -> Block -> Bool
isStopped brd = any cStopped . coords isStopped brd = any stopped . coords
where where
cStopped = (||) <$> inRow1 <*> (`M.member` brd) . (translate Down) stopped = (||) <$> atBottom <*> (`M.member` brd) . (translate Down)
inRow1 (V2 _ y) = y == 1 atBottom = (== 1) . (view _y)
hardDrop :: Game -> Game hardDrop :: Tetris ()
hardDrop g = g & block .~ hardDroppedBlock g hardDrop = hardDroppedBlock >>= assign block
hardDroppedBlock :: Game -> Block hardDroppedBlock :: Tetris Block
hardDroppedBlock g = translateBy n Down $ g ^. block hardDroppedBlock = do
where boardCoords <- M.keys <$> use board
n = minimum $ (subtract 1) <$> (minY : diffs) blockCoords <- coords <$> use block
diffs = [ y - yo | (V2 xo yo) <- brdCs, (V2 x y) <- blkCs, xo == x, yo < y ] let diffs =
brdCs = g ^. board ^. to M.keys [ y - yo
blkCs = g ^. block ^. to coords | (V2 xo yo) <- boardCoords
minY = minimum (fmap (^. _y) blkCs) , (V2 x y ) <- blockCoords
, xo == x
, yo < y
]
minY = minimum $ (view _y) <$> blockCoords
dist = minimum $ (subtract 1) <$> (minY : diffs)
translateBy dist Down <$> use block
-- | Freeze current block -- | Freeze current block
freezeBlock :: Game -> Game freezeBlock :: Tetris ()
freezeBlock g = g & board %~ (M.union blkMap) freezeBlock = do
where blk <- use block
blk = g ^. block modifying board $ M.union $ M.fromList [ (c, _shape blk) | c <- coords blk ]
blkMap = M.fromList $ [ (c, blk ^. shape) | c <- blk ^. to coords ]
-- | Replace block with next block -- | Replace block with next block
nextBlock :: Game -> IO Game nextBlock :: MonadIO m => TetrisT m ()
nextBlock g = do nextBlock = do
(t, ts) <- bagFourTetriminoEach (g ^. nextShapeBag) bag <- use nextShapeBag
pure (t, ts) <- liftIO $ bagFourTetriminoEach bag
$ g use nextShape >>= \s -> block .= initBlock s
& block .~ initBlock (g ^. nextShape) nextShape .= t
& nextShape .~ t nextShapeBag .= ts
& nextShapeBag .~ ts
-- | Try to shift current block; if shifting not possible, leave block where it is -- | Try to shift current block; if shifting not possible, leave block where it is
shift :: Direction -> Game -> Game shift :: Direction -> Tetris ()
shift d g = g & block %~ shiftBlock shift dir = do
where brd <- use board
shiftBlock b = if isValidBlockPosition (g ^. board) (translate d b) blk <- use block
then translate d b let candidate = translate dir blk
else b when (isValidBlockPosition brd candidate) $
block .= candidate
-- | Check if coordinate is already occupied or free in board -- | Check if coordinate is already occupied or free in board
isFree, isOccupied :: Board -> Coord -> Bool isFree :: Board -> Coord -> Bool
isFree = flip M.notMember isFree = flip M.notMember
isOccupied = flip M.member
-- | Check if coordinate is in or out of bounds -- | Check if coordinate is in or out of bounds
isInBounds, isOutOfBounds :: Coord -> Bool isInBounds :: Coord -> Bool
isInBounds (V2 x y) = 1 <= x && x <= boardWidth && 1 <= y isInBounds (V2 x y) = 1 <= x && x <= boardWidth && 1 <= y
isOutOfBounds = not . isInBounds
-- | Gravitate current block, i.e. shift down
gravitate :: Game -> Game
gravitate = shift Down
-- | Checks if block's potential new location is valid -- | Checks if block's potential new location is valid
isValidBlockPosition :: Board -> Block -> Bool isValidBlockPosition :: Board -> Block -> Bool
@ -305,8 +327,7 @@ shuffle xs
| null xs = mempty | null xs = mempty
| otherwise = do | otherwise = do
randomPosition <- getStdRandom (randomR (0, length xs - 1)) randomPosition <- getStdRandom (randomR (0, length xs - 1))
let (left, right) = Seq.splitAt randomPosition xs let (left, (y :<| ys)) = Seq.splitAt randomPosition xs
(y :< ys) = Seq.viewl right
fmap (y <|) (shuffle $ left >< ys) fmap (y <|) (shuffle $ left >< ys)
v2 :: (a, a) -> V2 a v2 :: (a, a) -> V2 a

60
src/UI/Game.hs
View file

@ -1,5 +1,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module UI.Game module UI.Game
( playGame ( playGame
@ -10,19 +11,19 @@ import Control.Monad (void, forever)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Prelude hiding (Left, Right) import Prelude hiding (Left, Right)
import Tetris
import Brick hiding (Down) import Brick hiding (Down)
import Brick.BChan import Brick.BChan
import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Border as B
import qualified Brick.Widgets.Border.Style as BS import qualified Brick.Widgets.Border.Style as BS
import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Center as C
import Control.Lens hiding (preview, op)
import Control.Monad.Trans.State
import qualified Graphics.Vty as V import qualified Graphics.Vty as V
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as M import qualified Data.Map as M
import Lens.Micro import Linear.V2 (V2(..))
import Lens.Micro.TH (makeLenses)
import Linear.V2 (V2(..), _x, _y) import Tetris
data UI = UI data UI = UI
{ _game :: Game -- ^ tetris game { _game :: Game -- ^ tetris game
@ -55,7 +56,7 @@ playGame :: Int -> Maybe String -> IO Game
playGame lvl mp = do playGame lvl mp = do
let delay = levelToDelay lvl let delay = levelToDelay lvl
chan <- newBChan 10 chan <- newBChan 10
forkIO $ forever $ do void . forkIO $ forever $ do
writeBChan chan Tick writeBChan chan Tick
threadDelay delay threadDelay delay
initialGame <- initGame lvl initialGame <- initGame lvl
@ -64,44 +65,45 @@ playGame lvl mp = do
return $ ui ^. game return $ ui ^. game
levelToDelay :: Int -> Int levelToDelay :: Int -> Int
levelToDelay n = floor $ 400000 * 0.85 ^ (2 * n) levelToDelay n = floor $ 400000 * (0.85 :: Double) ^ (2 * n)
-- Handling events -- Handling events
handleEvent :: UI -> BrickEvent Name Tick -> EventM Name (Next UI) handleEvent :: UI -> BrickEvent Name Tick -> EventM Name (Next UI)
handleEvent ui (AppEvent Tick) = handleTick ui handleEvent ui (AppEvent Tick) = handleTick ui
handleEvent ui (VtyEvent (V.EvKey V.KRight [])) = frozenGuard (shift Right) ui handleEvent ui (VtyEvent (V.EvKey V.KRight [])) = exec (shift Right) ui
handleEvent ui (VtyEvent (V.EvKey V.KLeft [])) = frozenGuard (shift Left) ui handleEvent ui (VtyEvent (V.EvKey V.KLeft [])) = exec (shift Left) ui
handleEvent ui (VtyEvent (V.EvKey V.KDown [])) = frozenGuard (shift Down) ui handleEvent ui (VtyEvent (V.EvKey V.KDown [])) = exec (shift Down) ui
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'l') [])) = frozenGuard (shift Right) ui handleEvent ui (VtyEvent (V.EvKey (V.KChar 'l') [])) = exec (shift Right) ui
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'h') [])) = frozenGuard (shift Left) ui handleEvent ui (VtyEvent (V.EvKey (V.KChar 'h') [])) = exec (shift Left) ui
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'j') [])) = frozenGuard (shift Down) ui handleEvent ui (VtyEvent (V.EvKey (V.KChar 'j') [])) = exec (shift Down) ui
handleEvent ui (VtyEvent (V.EvKey V.KUp [])) = frozenGuard rotate ui handleEvent ui (VtyEvent (V.EvKey V.KUp [])) = exec rotate ui
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'k') [])) = frozenGuard rotate ui handleEvent ui (VtyEvent (V.EvKey (V.KChar 'k') [])) = exec rotate ui
handleEvent ui (VtyEvent (V.EvKey (V.KChar ' ') [])) = continue $ ui & game %~ hardDrop handleEvent ui (VtyEvent (V.EvKey (V.KChar ' ') [])) = continue $ ui & game %~ execTetris hardDrop
& frozen .~ True & frozen .~ True
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart ui handleEvent ui (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart ui
handleEvent ui (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt ui handleEvent ui (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt ui
handleEvent ui (VtyEvent (V.EvKey V.KEsc [])) = halt ui handleEvent ui (VtyEvent (V.EvKey V.KEsc [])) = halt ui
handleEvent ui _ = continue ui handleEvent ui _ = continue ui
-- | If frozen, return same UI, else execute game op -- | This common execution function is used for all game input except hard
frozenGuard :: (Game -> Game) -> UI -> EventM Name (Next UI) -- drop. If frozen (from hard drop) do nothing, else execute the state
frozenGuard op ui = continue -- computation and unfreeze.
$ if ui ^. frozen exec :: Tetris () -> UI -> EventM Name (Next UI)
exec op ui = continue
$ if ui ^. frozen || ui ^. game . to isGameOver
then ui then ui
else ui & game %~ op else ui & game %~ execTetris op
-- | Handles time steps, does nothing if game is over -- | Handles time steps, does nothing if game is over
handleTick :: UI -> EventM Name (Next UI) handleTick :: UI -> EventM Name (Next UI)
handleTick ui = handleTick ui =
if isGameOver g if ui ^. game . to isGameOver
then continue ui then continue ui
else do else do
g' <- liftIO (timeStep g) next <- execStateT timeStep $ ui ^. game
continue $ ui & game .~ g' continue $ ui & game .~ next
& frozen .~ False & frozen .~ False
where g = ui ^. game
-- | Restart game at the same level -- | Restart game at the same level
restart :: UI -> EventM Name (Next UI) restart :: UI -> EventM Name (Next UI)
@ -133,7 +135,7 @@ drawGrid ui = hLimit 22
inRow r (V2 _ y) _ = r == y inRow r (V2 _ y) _ = r == y
gmap = mconcat [brdMap, cBlkMap, hrdMap, emptyCellMap] gmap = mconcat [brdMap, cBlkMap, hrdMap, emptyCellMap]
brdMap = draw Normal . Just <$> g ^. board brdMap = draw Normal . Just <$> g ^. board
hrdMap = blkMap (hardDroppedBlock g) HardDrop hrdMap = blkMap (evalTetris hardDroppedBlock g) HardDrop
cBlkMap = blkMap (g ^. block) Normal cBlkMap = blkMap (g ^. block) Normal
blkMap b v = M.fromList . map (, draw v . Just $ b ^. shape) $ coords b blkMap b v = M.fromList . map (, draw v . Just $ b ^. shape) $ coords b
draw = drawMCell (ui ^. preview) InGrid draw = drawMCell (ui ^. preview) InGrid
@ -155,6 +157,7 @@ drawCell _ t Normal = withAttr (tToAttr t) cw
drawCell Nothing t HardDrop = withAttr (tToAttrH t) hcw drawCell Nothing t HardDrop = withAttr (tToAttrH t) hcw
drawCell (Just p) t HardDrop = withAttr (tToAttrH t) (str p) drawCell (Just p) t HardDrop = withAttr (tToAttrH t) (str p)
tToAttr :: Tetrimino -> AttrName
tToAttr I = iAttr tToAttr I = iAttr
tToAttr O = oAttr tToAttr O = oAttr
tToAttr T = tAttr tToAttr T = tAttr
@ -163,6 +166,7 @@ tToAttr Z = zAttr
tToAttr J = jAttr tToAttr J = jAttr
tToAttr L = lAttr tToAttr L = lAttr
tToAttrH :: Tetrimino -> AttrName
tToAttrH I = ihAttr tToAttrH I = ihAttr
tToAttrH O = ohAttr tToAttrH O = ohAttr
tToAttrH T = thAttr tToAttrH T = thAttr
@ -194,7 +198,7 @@ drawStat s n = padLeftRight 1
$ str s <+> (padLeft Max $ str $ show n) $ str s <+> (padLeft Max $ str $ show n)
drawLeaderBoard :: Game -> Widget Name drawLeaderBoard :: Game -> Widget Name
drawLeaderBoard g = emptyWidget drawLeaderBoard _ = emptyWidget
drawInfo :: Game -> Widget Name drawInfo :: Game -> Widget Name
drawInfo g = hLimit 18 -- size of next piece box drawInfo g = hLimit 18 -- size of next piece box

2
src/UI/PickLevel.hs
View file

@ -4,8 +4,6 @@ module UI.PickLevel
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import Tetris
import Brick import Brick
import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Border as B
import qualified Brick.Widgets.Border.Style as BS import qualified Brick.Widgets.Border.Style as BS

6
tetris.cabal
View file

@ -19,17 +19,17 @@ library
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, brick , brick
, containers , containers
, microlens , lens
, microlens-th
, linear , linear
, random , random
, transformers
, vty , vty
default-language: Haskell2010 default-language: Haskell2010
executable tetris executable tetris
hs-source-dirs: app hs-source-dirs: app
main-is: Main.hs main-is: Main.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, directory , directory
, filepath , filepath