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

Simplify drawing cells

Browse source 
And only compute the hard drop preview when requested
This commit is contained in:
Sam Tay 2019-03-14 19:10:36 -04:00
parent bac99ab3c8
commit 8f506c37ba
1 changed files with 33 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

69
src/UI/Game.hs
View file

@ -7,7 +7,7 @@ module UI.Game
) where ) where
import Control.Concurrent (threadDelay, forkIO) import Control.Concurrent (threadDelay, forkIO)
import Control.Monad (guard, void, forever) 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)
@ -40,13 +40,9 @@ data Tick = Tick
-- | Named resources -- | Named resources
type Name = () type Name = ()
data CellLocation data VisualBlock
= InGrid = NormalBlock
| InNextShape | HardDropBlock String
data TVisual
= Normal
| HardDrop
-- App definition and execution -- App definition and execution
@ -165,30 +161,30 @@ drawGrid ui =
foldr (<+>) emptyWidget foldr (<+>) emptyWidget
. M.filterWithKey (\(V2 _ y) _ -> r == y) . M.filterWithKey (\(V2 _ y) _ -> r == y)
$ mconcat $ mconcat
[ draw Normal . Just <$> g ^. board [ drawBlockCell NormalBlock <$> ui ^. game ^. board
, blockMap (g ^. block) Normal , blockMap NormalBlock (ui ^. game ^. block)
, blockMap (evalTetris hardDroppedBlock g) HardDrop , case (ui ^. preview) of
Nothing -> M.empty
Just s -> blockMap (HardDropBlock s) (evalTetris hardDroppedBlock (ui ^. game))
, emptyCellMap , emptyCellMap
] ]
where where
g = ui ^. game blockMap v b =
draw = drawCell (ui ^. preview) InGrid M.fromList $ [ (c, drawBlockCell v (b ^. shape)) | c <- coords b ]
blockMap b v =
M.fromList $ [ (c, draw v . Just $ b ^. shape) | c <- coords b ]
emptyCellMap :: Map Coord (Widget Name) emptyCellMap :: Map Coord (Widget Name)
emptyCellMap = emptyCellMap = M.fromList
let ew = drawCell Nothing InGrid Normal Nothing [ ((V2 x y), emptyGridCellW) | x <- [1 .. boardWidth], y <- [1 .. boardHeight] ]
in M.fromList
[ ((V2 x y), ew) | x <- [1 .. boardWidth], y <- [1 .. boardHeight] ]
drawCell emptyGridCellW :: Widget Name
:: Maybe String -> CellLocation -> TVisual -> Maybe Tetrimino -> Widget Name emptyGridCellW = withAttr emptyAttr cw
drawCell _ InGrid _ Nothing = withAttr emptyAttr cw
drawCell _ InNextShape _ Nothing = withAttr emptyAttr ecw emptyNextShapeCellW :: Widget Name
drawCell Nothing _ HardDrop (Just _) = withAttr emptyAttr cw emptyNextShapeCellW = withAttr emptyAttr ecw
drawCell (Just p) _ HardDrop (Just t) = withAttr (tToAttrH t) (str p)
drawCell _ _ Normal (Just t) = withAttr (tToAttr t) cw drawBlockCell :: VisualBlock -> Tetrimino -> Widget Name
drawBlockCell NormalBlock t = withAttr (tToAttr t) cw
drawBlockCell (HardDropBlock s) t = withAttr (tToAttrH t) (str s)
tToAttr :: Tetrimino -> AttrName tToAttr :: Tetrimino -> AttrName
tToAttr I = iAttr tToAttr I = iAttr
@ -242,16 +238,17 @@ drawInfo g = hLimit 18 -- size of next piece box
drawNextShape :: Tetrimino -> Widget Name drawNextShape :: Tetrimino -> Widget Name
drawNextShape t = drawNextShape t =
withBorderStyle BS.unicodeBold withBorderStyle BS.unicodeBold
$ B.borderWithLabel (str "Next") $ B.borderWithLabel (str "Next")
$ padTopBottom 1 $ padTopBottom 1
$ padLeftRight 4 $ padLeftRight 4
$ vLimit 4 $ vLimit 4
$ vBox $ vBox
$ [0, -1] $ [0, -1] <&> \y ->
<&> \y -> hBox [ if V2 x y `elem` coords blk
hBox then drawBlockCell NormalBlock t
$ drawCell Nothing InNextShape Normal else emptyNextShapeCellW
<$> [ t <$ guard (V2 x y `elem` coords blk) | x <- [-2 .. 1] ] | x <- [-2 .. 1]
]
where blk = Block t (V2 0 0) (relCells t) where blk = Block t (V2 0 0) (relCells t)
drawHelp :: Widget Name drawHelp :: Widget Name