Disallow shifting after hard drop

src/Tetris.hs

@@ -53,6 +53,7 @@ data Game = Game
   , _rowClears    :: Seq.Seq Int
   , _score        :: Int
   , _board        :: Board
+  , _frozen       :: Bool
   } deriving (Eq, Show)
 
 makeLenses ''Game
@@ -142,17 +143,17 @@ 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 =
-  bool
-    <$> (pure . gravitate)                                    -- if not stopped
-    <*> nextBlock . updateScore . clearFullRows . freezeBlock -- if stopped
-    <*> blockStopped                                          -- predicate
+timeStep g = (& frozen .~ False)
+  <$> if blockStopped g
+         then nextBlock . updateScore . clearFullRows . freezeBlock $ g
+         else pure . gravitate $ g
 
 -- TODO check if mapKeysMonotonic works
 clearFullRows :: Game -> Game
@@ -218,6 +219,7 @@ 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 +247,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 isValidBlockPosition (g ^. board) (translate d b)
+  where shiftBlock b = if not (g ^. frozen) && isValidBlockPosition (g ^. board) (translate d b)
                           then translate d b
                           else b