tetris-core.hs

type Timer = ( Rational  -- ^ start time
             , Rational) -- ^ interval
 
createTimer :: Rational    -- ^ interval
               -> IO Timer
createTimer interval = 
    (\x -> (x, interval)) . toRational . utctDayTime <$> getCurrentTime
 
updateTimer :: Timer -> IO (Timer, Bool)
updateTimer (time, interval) =
   do newTime <- toRational . utctDayTime <$> getCurrentTime
      if (newTime - time) > interval
          then return ((newTime, interval), True)
          else return ((time, interval), False)
 
data GameState = GameState 
   { getWorld :: World
   , getTimer :: Timer 
   }

modifyWorld f (GameState w t) = GameState (f w) t
modifyTimer f (GameState w t) = GameState w (f t)
putWorld w (GameState _ t) = GameState w t
putTimer t (GameState w _) = GameState w t
getTimer' = gets getTimer
getWorld' = gets getWorld
putTimer' = modify . putTimer
putWorld' = modify . putWorld
modifyWorld' = modify . modifyWorld

updateTimer' :: StateT GameState IO Bool
updateTimer' = do
       (newFigureFallTimer, isFigureFallTime) <- lift . updateTimer =<< getTimer'
       putTimer' newFigureFallTimer
       return isFigureFallTime

gameLoop :: Int -> StateT GameState IO Int
gameLoop score = do
       lift $ threadDelay 10000
       isFigureFallTime <- updateTimer'

       key <- lift getKey
       let [userLeft, userRight, userRotate, userQuit] = (key ==) . Just <$> ['h', 'l', ' ', 'q']
       (moveL, moveR, moveD, canRotate) <- findPossibleMoves <$> getWorld'
       let horShift | userLeft && moveL = (-1)
                    | userRight && moveR = 1
                    | otherwise = 0
           downShift = fromEnum . (isFigureFallTime &&)
       (figureNotReachedBottom, isWorldUpdated) <- do 
          if userRotate && canRotate
            then do modifyWorld' $ translateFigure 0 (downShift moveD) . rotateFigure
                    return (moveD,  True)
            else do (_, _, moveD2, _) <- findPossibleMoves . translateFigure horShift 0 <$> getWorld'
                    modifyWorld' $ translateFigure horShift (downShift moveD2)
                    return (moveD2, horShift /= 0 || downShift moveD2 /= 0)
       (newScore, newRoundStarted) <- do
          if figureNotReachedBottom
             then return (score, False)
             else do (updatedField, linesRemoved) <- removeFilledLines <$> getWorld'
                     randomFigure <- lift $ randomItem figures
                     putWorld' $ World updatedField (Just (4, 0, randomFigure))
                     return (score + linesRemoved, True)
       let isWorldFilled = any (/= ' ') . head . uniteWith and'
       isGameOver <- isWorldFilled <$> getWorld'

       when (isWorldUpdated || newRoundStarted) $ lift . showWorld =<< getWorld'
       if userQuit || isGameOver
          then return newScore
          else gameLoop newScore

main = do timer <- createTimer 1
          score <- evalStateT (gameLoop 0) (GameState (World (emptyScreen 10 12) Nothing) timer)
          putStrLn ("Your score - " ++ (show score))