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

Implement custom hard drop previews

Browse source
This commit is contained in:
Sam Tay 2017-07-02 19:02:24 -04:00
parent 8e2240c87c
commit 2891f7883c
2 changed files with 71 additions and 46 deletions
Download patch file Download diff file Expand all files Collapse all files

13
src/Tetris.hs
View file

@ -53,7 +53,6 @@ data Game = Game
, _rowClears :: Seq.Seq Int , _rowClears :: Seq.Seq Int
, _score :: Int , _score :: Int
, _board :: Board , _board :: Board
, _frozen :: Bool
} deriving (Eq, Show) } deriving (Eq, Show)
makeLenses ''Game makeLenses ''Game
@ -141,17 +140,16 @@ initGame lvl = do
, _nextShapeBag = bag2 , _nextShapeBag = bag2
, _score = 0 , _score = 0
, _rowClears = mempty , _rowClears = mempty
, _frozen = False
, _board = mempty } , _board = mempty }
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 timeStep :: Game -> IO Game
timeStep g = (& frozen .~ False) timeStep g =
<$> if blockStopped g if blockStopped g
then nextBlock . updateScore . clearFullRows . freezeBlock $ g then nextBlock . updateScore . clearFullRows . freezeBlock $ g
else pure . gravitate $ g else pure . gravitate $ g
-- TODO check if mapKeysMonotonic works -- TODO check if mapKeysMonotonic works
clearFullRows :: Game -> Game clearFullRows :: Game -> Game
@ -217,7 +215,6 @@ isStopped brd = any cStopped . coords
hardDrop :: Game -> Game hardDrop :: Game -> Game
hardDrop g = g & block .~ hardDroppedBlock g hardDrop g = g & block .~ hardDroppedBlock g
& frozen .~ True
hardDroppedBlock :: Game -> Block hardDroppedBlock :: Game -> Block
hardDroppedBlock g = translateBy n Down $ g ^. block hardDroppedBlock g = translateBy n Down $ g ^. block
@ -245,7 +242,7 @@ nextBlock g = do
-- | 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 -> Game -> Game
shift d g = g & block %~ shiftBlock shift d g = g & block %~ shiftBlock
where shiftBlock b = if not (g ^. frozen) && isValidBlockPosition (g ^. board) (translate d b) where shiftBlock b = if isValidBlockPosition (g ^. board) (translate d b)
then translate d b then translate d b
else b else b

104
src/UI/Game.hs
View file

@ -1,3 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module UI.Game module UI.Game
@ -20,8 +21,17 @@ 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 Lens.Micro
import Lens.Micro.TH (makeLenses)
import Linear.V2 (V2(..), _x, _y) import Linear.V2 (V2(..), _x, _y)
data UI = UI
{ _game :: Game -- ^ tetris game
, _preview :: Maybe String -- ^ hard drop preview cell
, _frozen :: Bool -- ^ freeze after hard drop before time step
}
makeLenses ''UI
-- | Ticks mark passing of time -- | Ticks mark passing of time
data Tick = Tick data Tick = Tick
@ -33,7 +43,7 @@ data TVisual = Normal | HardDrop
-- App definition and execution -- App definition and execution
app :: App Game Tick Name app :: App UI Tick Name
app = App { appDraw = drawUI app = App { appDraw = drawUI
, appChooseCursor = neverShowCursor , appChooseCursor = neverShowCursor
, appHandleEvent = handleEvent , appHandleEvent = handleEvent
@ -42,53 +52,69 @@ app = App { appDraw = drawUI
} }
playGame :: Int -> Maybe String -> IO Game playGame :: Int -> Maybe String -> IO Game
playGame lvl _ = do playGame lvl mp = do
let delay = levelToDelay lvl let delay = levelToDelay lvl
chan <- newBChan 10 chan <- newBChan 10
forkIO $ forever $ do forkIO $ forever $ do
writeBChan chan Tick writeBChan chan Tick
threadDelay delay threadDelay delay
initialGame <- initGame lvl initialGame <- initGame lvl
customMain (V.mkVty V.defaultConfig) (Just chan) app initialGame let initialUI = UI initialGame mp False
ui <- customMain (V.mkVty V.defaultConfig) (Just chan) app initialUI
return $ ui ^. game
levelToDelay :: Int -> Int levelToDelay :: Int -> Int
levelToDelay n = floor $ 400000 * 0.85 ^ (2 * n) levelToDelay n = floor $ 400000 * 0.85 ^ (2 * n)
-- Handling events -- Handling events
handleEvent :: Game -> BrickEvent Name Tick -> EventM Name (Next Game) handleEvent :: UI -> BrickEvent Name Tick -> EventM Name (Next UI)
handleEvent g (AppEvent Tick) = handleTick g handleEvent ui (AppEvent Tick) = handleTick ui
handleEvent g (VtyEvent (V.EvKey V.KRight [])) = continue $ shift Right g handleEvent ui (VtyEvent (V.EvKey V.KRight [])) = frozenGuard (shift Right) ui
handleEvent g (VtyEvent (V.EvKey V.KLeft [])) = continue $ shift Left g handleEvent ui (VtyEvent (V.EvKey V.KLeft [])) = frozenGuard (shift Left) ui
handleEvent g (VtyEvent (V.EvKey V.KDown [])) = continue $ shift Down g handleEvent ui (VtyEvent (V.EvKey V.KDown [])) = frozenGuard (shift Down) ui
handleEvent g (VtyEvent (V.EvKey (V.KChar 'l') [])) = continue $ shift Right g handleEvent ui (VtyEvent (V.EvKey (V.KChar 'l') [])) = frozenGuard (shift Right) ui
handleEvent g (VtyEvent (V.EvKey (V.KChar 'h') [])) = continue $ shift Left g handleEvent ui (VtyEvent (V.EvKey (V.KChar 'h') [])) = frozenGuard (shift Left) ui
handleEvent g (VtyEvent (V.EvKey (V.KChar 'j') [])) = continue $ shift Down g handleEvent ui (VtyEvent (V.EvKey (V.KChar 'j') [])) = frozenGuard (shift Down) ui
handleEvent g (VtyEvent (V.EvKey (V.KChar ' ') [])) = continue $ hardDrop g handleEvent ui (VtyEvent (V.EvKey V.KUp [])) = frozenGuard rotate ui
handleEvent g (VtyEvent (V.EvKey V.KUp [])) = continue $ rotate g handleEvent ui (VtyEvent (V.EvKey (V.KChar 'k') [])) = frozenGuard rotate ui
handleEvent g (VtyEvent (V.EvKey (V.KChar 'k') [])) = continue $ rotate g handleEvent ui (VtyEvent (V.EvKey (V.KChar ' ') [])) = continue $ ui & game %~ hardDrop
handleEvent g (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt g & frozen .~ True
handleEvent g (VtyEvent (V.EvKey V.KEsc [])) = halt g handleEvent ui (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt ui
handleEvent g _ = continue g handleEvent ui (VtyEvent (V.EvKey V.KEsc [])) = halt ui
handleEvent ui _ = continue ui
-- | If frozen, return same UI, else execute game op
frozenGuard :: (Game -> Game) -> UI -> EventM Name (Next UI)
frozenGuard op ui = continue
$ if ui ^. frozen
then ui
else ui & game %~ op
-- | Handles time steps, does nothing if game is over -- | Handles time steps, does nothing if game is over
handleTick :: Game -> EventM Name (Next Game) handleTick :: UI -> EventM Name (Next UI)
handleTick g = if isGameOver g handleTick ui =
then continue g if isGameOver g
else liftIO (timeStep g) >>= continue then continue ui
else do
g' <- liftIO (timeStep g)
continue $ ui & game .~ g'
& frozen .~ False
where g = ui ^. game
-- Drawing -- Drawing
drawUI :: Game -> [Widget Name] drawUI :: UI -> [Widget Name]
drawUI g = drawUI ui =
[ C.vCenter $ vLimit 22 $ hBox [ padLeft Max $ padRight (Pad 2) $ drawStats g [ C.vCenter $ vLimit 22 $ hBox [ padLeft Max $ padRight (Pad 2) $ drawStats (ui ^. game)
, drawGrid g , drawGrid ui
, padRight Max $ padLeft (Pad 2) $ drawInfo g , padRight Max $ padLeft (Pad 2) $ drawInfo (ui ^. game)
] ]
] ]
drawGrid :: Game -> Widget Name drawGrid :: UI -> Widget Name
drawGrid g = hLimit 22 drawGrid ui = hLimit 22
$ withBorderStyle BS.unicodeBold $ withBorderStyle BS.unicodeBold
$ B.borderWithLabel (str "Tetris") $ B.borderWithLabel (str "Tetris")
$ vBox rows $ vBox rows
@ -102,22 +128,24 @@ drawGrid g = hLimit 22
hrdMap = blkMap (hardDroppedBlock g) HardDrop hrdMap = blkMap (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 InGrid draw = drawMCell (ui ^. preview) InGrid
g = ui ^. game
emptyCellMap :: Map Coord (Widget Name) emptyCellMap :: Map Coord (Widget Name)
emptyCellMap = M.fromList cws emptyCellMap = M.fromList cws
where where
cws = [((V2 x y), ew) | x <- [1..boardWidth], y <- [1..boardHeight]] cws = [((V2 x y), ew) | x <- [1..boardWidth], y <- [1..boardHeight]]
ew = drawMCell InGrid Normal Nothing ew = drawMCell Nothing InGrid Normal Nothing
drawMCell :: CellLocation -> TVisual -> Maybe Tetrimino -> Widget Name drawMCell :: Maybe String -> CellLocation -> TVisual -> Maybe Tetrimino -> Widget Name
drawMCell InGrid _ Nothing = withAttr emptyAttr cw drawMCell _ InGrid _ Nothing = withAttr emptyAttr cw
drawMCell InNextShape _ Nothing = withAttr emptyAttr ecw drawMCell _ InNextShape _ Nothing = withAttr emptyAttr ecw
drawMCell _ v (Just t) = drawCell t v drawMCell mp _ v (Just t) = drawCell mp t v
drawCell :: Tetrimino -> TVisual -> Widget Name drawCell :: Maybe String -> Tetrimino -> TVisual -> Widget Name
drawCell t Normal = withAttr (tToAttr t) cw drawCell _ t Normal = withAttr (tToAttr t) cw
drawCell t HardDrop = withAttr (tToAttrH t) hcw drawCell Nothing t HardDrop = withAttr (tToAttrH t) hcw
drawCell (Just p) t HardDrop = withAttr (tToAttrH t) (str p)
tToAttr I = iAttr tToAttr I = iAttr
tToAttr O = oAttr tToAttr O = oAttr
@ -174,7 +202,7 @@ drawNextShape t = withBorderStyle BS.unicodeBold
$ vLimit 4 $ vLimit 4
$ vBox $ mkRow <$> [0,-1] $ vBox $ mkRow <$> [0,-1]
where where
mkRow y = hBox $ drawMCell InNextShape Normal . cellAt . (`V2` y) <$> [-2..1] mkRow y = hBox $ drawMCell Nothing InNextShape Normal . cellAt . (`V2` y) <$> [-2..1]
cellAt (V2 x y) = if (V2 x y) `elem` cs then Just t else Nothing cellAt (V2 x y) = if (V2 x y) `elem` cs then Just t else Nothing
blk = Block t (V2 0 0) (relCells t) blk = Block t (V2 0 0) (relCells t)
cs = blk ^. to coords cs = blk ^. to coords