Refactor
This commit is contained in:
Sam Tay
parent
bcd6b38978
commit
e8c6c804c5
3 changed files with 37 additions and 57 deletions
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
|
@ -11,7 +12,6 @@ module Tetris
|
|||
, rotate
|
||||
, hardDrop
|
||||
-- Game state handlers
|
||||
, execTetris
|
||||
, evalTetris
|
||||
-- Game state queries
|
||||
, isGameOver
|
||||
|
|
@ -33,9 +33,10 @@ module Tetris
|
|||
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 Control.Monad.IO.Class (MonadIO(..), liftIO)
|
||||
import Control.Monad.State.Class (MonadState, gets)
|
||||
import Control.Monad.Trans.State (evalStateT)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Sequence (Seq(..), (><))
|
||||
|
|
@ -44,6 +45,7 @@ import Control.Lens hiding (Empty)
|
|||
import Linear.V2 (V2(..), _y)
|
||||
import qualified Linear.V2 as LV
|
||||
import System.Random (getStdRandom, randomR)
|
||||
|
||||
-- Types and instances
|
||||
|
||||
-- | Tetris shape types
|
||||
|
|
@ -83,14 +85,10 @@ data Game = Game
|
|||
} deriving (Eq, Show)
|
||||
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
|
||||
type Tetris a = forall m. MonadState Game m => m a
|
||||
|
||||
-- Translate class for direct translations, without concern for boundaries
|
||||
-- 'shift' concerns safe translations with boundaries
|
||||
|
|
@ -181,7 +179,7 @@ isGameOver :: Game -> Bool
|
|||
isGameOver g = blockStopped g && g ^. (block . origin) == startOrigin
|
||||
|
||||
-- | The main game execution, this is executed at each discrete time step
|
||||
timeStep :: MonadIO m => TetrisT m ()
|
||||
timeStep :: (MonadIO m, MonadState Game m) => m ()
|
||||
timeStep = do
|
||||
gets blockStopped >>= \case
|
||||
False -> gravitate
|
||||
|
|
@ -193,11 +191,11 @@ timeStep = do
|
|||
nextBlock
|
||||
|
||||
-- | Gravitate current block, i.e. shift down
|
||||
gravitate :: Tetris ()
|
||||
gravitate :: MonadState Game m => m ()
|
||||
gravitate = shift Down
|
||||
|
||||
-- | If necessary: clear full rows and return the count
|
||||
clearFullRows :: Tetris Int
|
||||
clearFullRows :: MonadState Game m => m Int
|
||||
clearFullRows = do
|
||||
brd <- use board
|
||||
let rowSize r = length $ M.filterWithKey (\(V2 _ y) _ -> r == y) brd
|
||||
|
|
@ -210,7 +208,7 @@ clearFullRows = do
|
|||
return $ length fullRows
|
||||
|
||||
-- | Empties row on 0, otherwise appends value (just keeps consecutive information)
|
||||
addToRowClears :: Int -> Tetris ()
|
||||
addToRowClears :: MonadState Game m => Int -> m ()
|
||||
addToRowClears 0 = rowClears .= mempty
|
||||
addToRowClears n = rowClears %= (|> n)
|
||||
|
||||
|
|
@ -220,7 +218,7 @@ addToRowClears n = rowClears %= (|> n)
|
|||
-- 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,
|
||||
-- but you do get more points for more rows cleared at once.
|
||||
updateScore :: Tetris ()
|
||||
updateScore :: MonadState Game m => m ()
|
||||
updateScore = do
|
||||
multiplier <- (1 +) <$> use level
|
||||
clears <- latestOrZero <$> use rowClears
|
||||
|
|
@ -240,7 +238,7 @@ updateScore = do
|
|||
|
||||
-- | Handle counterclockwise block rotation (if possible)
|
||||
-- Allows wallkicks: http://tetris.wikia.com/wiki/TGM_rotation
|
||||
rotate :: Tetris ()
|
||||
rotate :: MonadState Game m => m ()
|
||||
rotate = do
|
||||
blk <- use block
|
||||
brd <- use board
|
||||
|
|
@ -264,10 +262,10 @@ isStopped brd = any stopped . coords
|
|||
stopped = (||) <$> atBottom <*> (`M.member` brd) . translate Down
|
||||
atBottom = (== 1) . view _y
|
||||
|
||||
hardDrop :: Tetris ()
|
||||
hardDrop :: MonadState Game m => m ()
|
||||
hardDrop = hardDroppedBlock >>= assign block
|
||||
|
||||
hardDroppedBlock :: Tetris Block
|
||||
hardDroppedBlock :: MonadState Game m => m Block
|
||||
hardDroppedBlock = do
|
||||
boardCoords <- M.keys <$> use board
|
||||
blockCoords <- coords <$> use block
|
||||
|
|
@ -283,13 +281,13 @@ hardDroppedBlock = do
|
|||
translateBy dist Down <$> use block
|
||||
|
||||
-- | Freeze current block
|
||||
freezeBlock :: Tetris ()
|
||||
freezeBlock :: MonadState Game m => m ()
|
||||
freezeBlock = do
|
||||
blk <- use block
|
||||
modifying board $ M.union $ M.fromList [ (c, _shape blk) | c <- coords blk ]
|
||||
|
||||
-- | Replace block with next block
|
||||
nextBlock :: MonadIO m => TetrisT m ()
|
||||
nextBlock :: (MonadIO m, MonadState Game m) => m ()
|
||||
nextBlock = do
|
||||
bag <- use nextShapeBag
|
||||
(t, ts) <- liftIO $ bagFourTetriminoEach bag
|
||||
|
|
@ -298,7 +296,7 @@ nextBlock = do
|
|||
nextShapeBag .= ts
|
||||
|
||||
-- | Try to shift current block; if shifting not possible, leave block where it is
|
||||
shift :: Direction -> Tetris ()
|
||||
shift :: MonadState Game m => Direction -> m ()
|
||||
shift dir = do
|
||||
brd <- use board
|
||||
blk <- use block
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
|
@ -7,9 +8,7 @@ module UI.Game
|
|||
) where
|
||||
|
||||
import Control.Concurrent (threadDelay, forkIO)
|
||||
import Control.Monad (void, forever, when, unless)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.State (execStateT)
|
||||
import Control.Monad (void, forever)
|
||||
import Prelude hiding (Left, Right)
|
||||
|
||||
import Brick hiding (Down)
|
||||
|
|
@ -18,6 +17,8 @@ import qualified Brick.Widgets.Border as B
|
|||
import qualified Brick.Widgets.Border.Style as BS
|
||||
import qualified Brick.Widgets.Center as C
|
||||
import Control.Lens hiding (preview, op, zoom)
|
||||
import Control.Monad.Extra (orM, unlessM)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Graphics.Vty as V
|
||||
import qualified Graphics.Vty.CrossPlatform
|
||||
import qualified Graphics.Vty.Config
|
||||
|
|
@ -84,7 +85,9 @@ levelToDelay n = floor $ 400000 * (0.85 :: Double) ^ (2 * n)
|
|||
-- Handling events
|
||||
|
||||
handleEvent :: BrickEvent Name Tick -> EventM Name UI ()
|
||||
handleEvent (AppEvent Tick ) = handleTick
|
||||
handleEvent (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart
|
||||
handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt
|
||||
handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt
|
||||
handleEvent (VtyEvent (V.EvKey V.KRight [])) = exec (shift Right)
|
||||
handleEvent (VtyEvent (V.EvKey V.KLeft [])) = exec (shift Left)
|
||||
handleEvent (VtyEvent (V.EvKey V.KDown [])) = exec (shift Down)
|
||||
|
|
@ -94,53 +97,31 @@ handleEvent (VtyEvent (V.EvKey (V.KChar 'j') [])) = exec (shift Down)
|
|||
handleEvent (VtyEvent (V.EvKey V.KUp [])) = exec rotate
|
||||
handleEvent (VtyEvent (V.EvKey (V.KChar 'k') [])) = exec rotate
|
||||
handleEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) =
|
||||
guarded
|
||||
(not . view paused)
|
||||
(over game (execTetris hardDrop) . set locked True)
|
||||
unlessM (orM [use paused, use (game . to isGameOver)]) $ do
|
||||
zoom game hardDrop
|
||||
assign locked True
|
||||
handleEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) =
|
||||
guarded
|
||||
(not . view locked)
|
||||
(over paused not)
|
||||
handleEvent (VtyEvent (V.EvKey (V.KChar 'r') [])) = restart
|
||||
handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt
|
||||
handleEvent (VtyEvent (V.EvKey V.KEsc [])) = halt
|
||||
unlessM (orM [use locked, use (game . to isGameOver)]) $ do
|
||||
modifying paused not
|
||||
handleEvent (AppEvent Tick ) =
|
||||
unlessM (orM [use paused, use (game . to isGameOver)]) $ do
|
||||
zoom game timeStep
|
||||
assign locked False
|
||||
handleEvent _ = pure ()
|
||||
|
||||
-- | This common execution function is used for all game user input except hard
|
||||
-- drop and pause. If paused or locked (from hard drop) do nothing, else
|
||||
-- execute the state computation.
|
||||
exec :: Tetris () -> EventM Name UI ()
|
||||
exec op =
|
||||
guarded
|
||||
(not . \ui -> ui ^. paused || ui ^. locked)
|
||||
(game %~ execTetris op)
|
||||
|
||||
-- | This base execution function takes a predicate and only issues UI
|
||||
-- modification when predicate passes and game is not over.
|
||||
guarded :: (UI -> Bool) -> (UI -> UI) -> EventM Name UI ()
|
||||
guarded p f = do
|
||||
ui <- get
|
||||
when (p ui && not (ui ^. game . to isGameOver)) $
|
||||
modify f
|
||||
|
||||
-- | Handles time steps, does nothing if game is over or paused
|
||||
handleTick :: EventM Name UI ()
|
||||
handleTick = do
|
||||
ui <- get
|
||||
unless (ui ^. paused || ui ^. game . to isGameOver) $ do
|
||||
-- awkward, should just mutate the inner state
|
||||
--zoom game timeStep
|
||||
g' <- execStateT timeStep $ ui ^. game
|
||||
game .= g'
|
||||
locked .= False
|
||||
exec = unlessM (orM [use paused, use locked, use (game . to isGameOver)]) . zoom game
|
||||
|
||||
-- | Restart game at the same level
|
||||
restart :: EventM Name UI ()
|
||||
restart = do
|
||||
lvl <- use $ game . level
|
||||
g <- liftIO $ initGame lvl
|
||||
game .= g
|
||||
locked .= False
|
||||
assign game g
|
||||
assign locked False
|
||||
|
||||
-- Drawing
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue