Refactor

src/Tetris.hs

@@ -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

src/UI/Game.hs

@@ -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
 

tetris.cabal

@@ -19,6 +19,7 @@ library
   build-depends:       base >= 4.7 && < 5
                      , brick
                      , containers
+                     , extra
                      , lens
                      , linear
                      , mtl