From 2891f7883ca4033e7d67770e8a5a69f6695c2788 Mon Sep 17 00:00:00 2001 From: Sam Tay Date: Sun, 2 Jul 2017 19:02:24 -0400 Subject: [PATCH] Implement custom hard drop previews --- src/Tetris.hs | 13 +++---- src/UI/Game.hs | 104 +++++++++++++++++++++++++++++++------------------ 2 files changed, 71 insertions(+), 46 deletions(-) diff --git a/src/Tetris.hs b/src/Tetris.hs index 488adac..3a60248 100644 --- a/src/Tetris.hs +++ b/src/Tetris.hs @@ -53,7 +53,6 @@ data Game = Game , _rowClears :: Seq.Seq Int , _score :: Int , _board :: Board - , _frozen :: Bool } deriving (Eq, Show) makeLenses ''Game @@ -141,17 +140,16 @@ initGame lvl = do , _nextShapeBag = bag2 , _score = 0 , _rowClears = mempty - , _frozen = False , _board = mempty } isGameOver :: Game -> Bool isGameOver g = blockStopped g && g ^. block ^. origin == startOrigin timeStep :: Game -> IO Game -timeStep g = (& frozen .~ False) - <$> if blockStopped g - then nextBlock . updateScore . clearFullRows . freezeBlock $ g - else pure . gravitate $ g +timeStep g = + if blockStopped g + then nextBlock . updateScore . clearFullRows . freezeBlock $ g + else pure . gravitate $ g -- TODO check if mapKeysMonotonic works clearFullRows :: Game -> Game @@ -217,7 +215,6 @@ isStopped brd = any cStopped . coords hardDrop :: Game -> Game hardDrop g = g & block .~ hardDroppedBlock g - & frozen .~ True hardDroppedBlock :: Game -> 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 shift :: Direction -> Game -> Game 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 else b diff --git a/src/UI/Game.hs b/src/UI/Game.hs index ee9bf4e..2935829 100644 --- a/src/UI/Game.hs +++ b/src/UI/Game.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module UI.Game @@ -20,8 +21,17 @@ import qualified Graphics.Vty as V import Data.Map (Map) import qualified Data.Map as M import Lens.Micro +import Lens.Micro.TH (makeLenses) 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 data Tick = Tick @@ -33,7 +43,7 @@ data TVisual = Normal | HardDrop -- App definition and execution -app :: App Game Tick Name +app :: App UI Tick Name app = App { appDraw = drawUI , appChooseCursor = neverShowCursor , appHandleEvent = handleEvent @@ -42,53 +52,69 @@ app = App { appDraw = drawUI } playGame :: Int -> Maybe String -> IO Game -playGame lvl _ = do +playGame lvl mp = do let delay = levelToDelay lvl chan <- newBChan 10 forkIO $ forever $ do writeBChan chan Tick threadDelay delay 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 n = floor $ 400000 * 0.85 ^ (2 * n) -- Handling events -handleEvent :: Game -> BrickEvent Name Tick -> EventM Name (Next Game) -handleEvent g (AppEvent Tick) = handleTick g -handleEvent g (VtyEvent (V.EvKey V.KRight [])) = continue $ shift Right g -handleEvent g (VtyEvent (V.EvKey V.KLeft [])) = continue $ shift Left g -handleEvent g (VtyEvent (V.EvKey V.KDown [])) = continue $ shift Down g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'l') [])) = continue $ shift Right g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'h') [])) = continue $ shift Left g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'j') [])) = continue $ shift Down g -handleEvent g (VtyEvent (V.EvKey (V.KChar ' ') [])) = continue $ hardDrop g -handleEvent g (VtyEvent (V.EvKey V.KUp [])) = continue $ rotate g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'k') [])) = continue $ rotate g -handleEvent g (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt g -handleEvent g (VtyEvent (V.EvKey V.KEsc [])) = halt g -handleEvent g _ = continue g +handleEvent :: UI -> BrickEvent Name Tick -> EventM Name (Next UI) +handleEvent ui (AppEvent Tick) = handleTick ui +handleEvent ui (VtyEvent (V.EvKey V.KRight [])) = frozenGuard (shift Right) ui +handleEvent ui (VtyEvent (V.EvKey V.KLeft [])) = frozenGuard (shift Left) ui +handleEvent ui (VtyEvent (V.EvKey V.KDown [])) = frozenGuard (shift Down) ui +handleEvent ui (VtyEvent (V.EvKey (V.KChar 'l') [])) = frozenGuard (shift Right) ui +handleEvent ui (VtyEvent (V.EvKey (V.KChar 'h') [])) = frozenGuard (shift Left) ui +handleEvent ui (VtyEvent (V.EvKey (V.KChar 'j') [])) = frozenGuard (shift Down) ui +handleEvent ui (VtyEvent (V.EvKey V.KUp [])) = frozenGuard rotate ui +handleEvent ui (VtyEvent (V.EvKey (V.KChar 'k') [])) = frozenGuard rotate ui +handleEvent ui (VtyEvent (V.EvKey (V.KChar ' ') [])) = continue $ ui & game %~ hardDrop + & frozen .~ True +handleEvent ui (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt ui +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 -handleTick :: Game -> EventM Name (Next Game) -handleTick g = if isGameOver g - then continue g - else liftIO (timeStep g) >>= continue +handleTick :: UI -> EventM Name (Next UI) +handleTick ui = + if isGameOver g + then continue ui + else do + g' <- liftIO (timeStep g) + continue $ ui & game .~ g' + & frozen .~ False + where g = ui ^. game + -- Drawing -drawUI :: Game -> [Widget Name] -drawUI g = - [ C.vCenter $ vLimit 22 $ hBox [ padLeft Max $ padRight (Pad 2) $ drawStats g - , drawGrid g - , padRight Max $ padLeft (Pad 2) $ drawInfo g +drawUI :: UI -> [Widget Name] +drawUI ui = + [ C.vCenter $ vLimit 22 $ hBox [ padLeft Max $ padRight (Pad 2) $ drawStats (ui ^. game) + , drawGrid ui + , padRight Max $ padLeft (Pad 2) $ drawInfo (ui ^. game) ] ] -drawGrid :: Game -> Widget Name -drawGrid g = hLimit 22 +drawGrid :: UI -> Widget Name +drawGrid ui = hLimit 22 $ withBorderStyle BS.unicodeBold $ B.borderWithLabel (str "Tetris") $ vBox rows @@ -102,22 +128,24 @@ drawGrid g = hLimit 22 hrdMap = blkMap (hardDroppedBlock g) HardDrop cBlkMap = blkMap (g ^. block) Normal 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 = M.fromList cws where 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 InGrid _ Nothing = withAttr emptyAttr cw -drawMCell InNextShape _ Nothing = withAttr emptyAttr ecw -drawMCell _ v (Just t) = drawCell t v +drawMCell :: Maybe String -> CellLocation -> TVisual -> Maybe Tetrimino -> Widget Name +drawMCell _ InGrid _ Nothing = withAttr emptyAttr cw +drawMCell _ InNextShape _ Nothing = withAttr emptyAttr ecw +drawMCell mp _ v (Just t) = drawCell mp t v -drawCell :: Tetrimino -> TVisual -> Widget Name -drawCell t Normal = withAttr (tToAttr t) cw -drawCell t HardDrop = withAttr (tToAttrH t) hcw +drawCell :: Maybe String -> Tetrimino -> TVisual -> Widget Name +drawCell _ t Normal = withAttr (tToAttr t) cw +drawCell Nothing t HardDrop = withAttr (tToAttrH t) hcw +drawCell (Just p) t HardDrop = withAttr (tToAttrH t) (str p) tToAttr I = iAttr tToAttr O = oAttr @@ -174,7 +202,7 @@ drawNextShape t = withBorderStyle BS.unicodeBold $ vLimit 4 $ vBox $ mkRow <$> [0,-1] 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 blk = Block t (V2 0 0) (relCells t) cs = blk ^. to coords