Implement leveling

src/Tetris.hs

@@ -25,7 +25,7 @@ module Tetris
   , Tetrimino(..)
   , Tetris
   -- Lenses
-  , block, board, level, nextShape, score, shape
+  , block, board, level, nextShape, score, shape, linesCleared
   -- Constants
   , boardHeight, boardWidth, relCells
   ) where
@@ -35,7 +35,7 @@ import Control.Applicative ((<|>))
 import Control.Monad (forM_, mfilter, when, (<=<))
 
 import Control.Monad.IO.Class (MonadIO(..), liftIO)
-import Control.Monad.State.Class (MonadState, gets)
+import Control.Monad.State.Class (MonadState, gets, put)
 import Control.Monad.Trans.State (evalStateT)
 import Data.Map (Map)
 import qualified Data.Map as M
@@ -79,10 +79,10 @@ data Game = Game
   , _block        :: Block
   , _nextShape    :: Tetrimino
   , _nextShapeBag :: Seq.Seq Tetrimino
-  , _rowClears    :: Seq.Seq Int
+  , _linesCleared :: Int
   , _score        :: Int
   , _board        :: Board
-  } deriving (Eq, Show)
+  } deriving (Eq)
 makeLenses ''Game
 
 evalTetris :: Tetris a -> Game -> a
@@ -171,10 +171,23 @@ initGame lvl = do
     , _nextShape    = s2
     , _nextShapeBag = bag2
     , _score        = 0
-    , _rowClears    = mempty
+    , _linesCleared = 0
     , _board        = mempty
     }
 
+-- | Increment level and reset the board
+nextLevel :: (MonadIO m, MonadState Game m) => m ()
+nextLevel = do
+  -- Increment level
+  level %= (+ 1)
+  -- Reset board
+  (s1, bag1) <- liftIO $ bagFourTetriminoEach mempty
+  (s2, bag2) <- liftIO $ bagFourTetriminoEach bag1
+  block .= initBlock s1
+  nextShape .= s2
+  nextShapeBag .= bag2
+  board .= mempty
+
 isGameOver :: Game -> Bool
 isGameOver g = blockStopped g && g ^. (block . origin) == startOrigin
 
@@ -185,10 +198,10 @@ timeStep = do
     False -> gravitate
     True -> do
       freezeBlock
-      n <- clearFullRows
-      addToRowClears n
-      updateScore
-      nextBlock
+      clearFullRows >>= updateScore
+      levelFinished >>= \case
+        True -> nextLevel
+        False -> nextBlock
 
 -- | Gravitate current block, i.e. shift down
 gravitate :: MonadState Game m => m ()
@@ -205,36 +218,34 @@ clearFullRows = do
   -- Shift cells above full rows
   modifying board $ M.mapKeysMonotonic $ over _y $ \y ->
     y - length (filter (< y) fullRows)
-  return $ length fullRows
-
--- | Empties row on 0, otherwise appends value (just keeps consecutive information)
-addToRowClears :: MonadState Game m => Int -> m ()
-addToRowClears 0 = rowClears .= mempty
-addToRowClears n = rowClears %= (|> n)
+  let clearedLines = length fullRows
+  linesCleared %= (+ clearedLines)
+  pure clearedLines
 
--- | This updates game points with respect to the current
--- _rowClears value (thus should only be used ONCE per step)
+-- | This updates game points with respect to the provided number of cleared
+-- lines.
 --
--- 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 :: MonadState Game m => m ()
-updateScore = do
-  multiplier <- (1 +) <$> use level
-  clears <- latestOrZero <$> use rowClears
-  let newPoints = multiplier * points clears
+-- See https://tetris.fandom.com/wiki/Scoring
+updateScore :: (MonadState Game m, MonadIO m) => Int -> m ()
+updateScore 0 = pure ()
+updateScore lines = do
+  lvl <- use level
+  let newPoints = (lvl + 1) * points lines
   score %= (+ newPoints)
   where
-    -- Translate row clears to points
+    -- Translate row line clears to points
     points 0 = 0
     points 1 = 40
     points 2 = 100
     points 3 = 300
-    points _ = 800
-    -- | Get last value of sequence or 0 if empty
-    latestOrZero :: Seq.Seq Int -> Int
-    latestOrZero Empty     = 0
-    latestOrZero (_ :|> n) = n
+    points _ = 1200
+
+-- | Using the fixed-goal system described here: https://tetris.wiki/Marathon
+levelFinished :: (MonadState Game m, MonadIO m) => m Bool
+levelFinished = do
+  lvl <- use level
+  lc <- use linesCleared
+  pure $ lvl < 15 && lc >= 10 * (lvl + 1)
 
 -- | Handle counterclockwise block rotation (if possible)
 -- Allows wallkicks: http://tetris.wikia.com/wiki/TGM_rotation

src/UI/Game.hs

@@ -8,6 +8,7 @@ module UI.Game
   ) where
 
 import Control.Concurrent (threadDelay, forkIO)
+import Control.Concurrent.STM (TVar, newTVarIO, readTVarIO, writeTVar, atomically)
 import Control.Monad (void, forever)
 import Prelude hiding (Left, Right)
 
@@ -29,10 +30,12 @@ import Linear.V2 (V2(..))
 import Tetris
 
 data UI = UI
-  { _game    :: Game         -- ^ tetris game
-  , _preview :: Maybe String -- ^ hard drop preview cell
-  , _locked  :: Bool         -- ^ lock after hard drop before time step
-  , _paused  :: Bool         -- ^ game paused
+  { _game      :: Game         -- ^ tetris game
+  , _initLevel :: Int          -- ^ initial level chosen
+  , _currLevel :: TVar Int     -- ^ current level
+  , _preview   :: Maybe String -- ^ hard drop preview cell
+  , _locked    :: Bool         -- ^ lock after hard drop before time step
+  , _paused    :: Bool         -- ^ game paused
   }
 
 makeLenses ''UI
@@ -63,16 +66,20 @@ playGame
   -> Maybe String -- ^ Preview cell (Nothing == no preview)
   -> IO Game
 playGame lvl mp = do
-  let delay = levelToDelay lvl
   chan <- newBChan 10
+  -- share the current level with the thread so it can adjust speed
+  tv <- newTVarIO lvl
   void . forkIO $ forever $ do
     writeBChan chan Tick
-    threadDelay delay
+    lvl <- readTVarIO tv
+    threadDelay $ levelToDelay lvl
   initialGame <- initGame lvl
   let buildVty = Graphics.Vty.CrossPlatform.mkVty Graphics.Vty.Config.defaultConfig
   initialVty <- buildVty
   ui <- customMain initialVty buildVty (Just chan) app $ UI
     { _game    = initialGame
+    , _initLevel = lvl
+    , _currLevel = tv
     , _preview = mp
     , _locked  = False
     , _paused  = False
@@ -106,6 +113,10 @@ handleEvent (VtyEvent (V.EvKey (V.KChar 'p') [])) =
 handleEvent (AppEvent Tick                      ) =
   unlessM (orM [use paused, use (game . to isGameOver)]) $ do
     zoom game timeStep
+    -- Keep level in sync with ticker (gross)
+    lvl <- use $ game . level
+    tv <- use $ currLevel
+    liftIO . atomically $ writeTVar tv lvl
     assign locked False
 handleEvent _ = pure ()
 
@@ -115,10 +126,10 @@ handleEvent _ = pure ()
 exec :: Tetris () -> EventM Name UI ()
 exec = unlessM (orM [use paused, use locked, use (game . to isGameOver)]) . zoom game
 
--- | Restart game at the same level
+-- | Restart game at the initially chosen level
 restart :: EventM Name UI ()
 restart = do
-  lvl <- use $ game . level
+  lvl <- use $ initLevel
   g <- liftIO $ initGame lvl
   assign game g
   assign locked False
@@ -201,6 +212,7 @@ drawStats g =
     $ B.borderWithLabel (str "Stats")
     $ vBox
         [ drawStat "Score" $ g ^. score
+        , padTop (Pad 1) $ drawStat "Lines" $ g ^. linesCleared
         , padTop (Pad 1) $ drawStat "Level" $ g ^. level
         , drawLeaderBoard g
         ]

tetris.cabal

@@ -24,6 +24,7 @@ library
                      , linear
                      , mtl
                      , random
+                     , stm
                      , transformers
                      , vty
                      , vty-crossplatform