Console Tetris

hask5.lhs

    ТЕТРІС 0.0.0.12

Реалізація класичного тетріса (з урізаними можливостями), з виводом у консоль.
Урізано: відображення наступної фігури та рахунку
         клавіша прискореного падіння фігури
         рівні та зміна швидкостей

Код переписано багато разів, з кожним разом він ставав все кращим та кращим.

> {-# LANGUAGE TemplateHaskell #-}
> import Data.List
> import System.Random
> import System.IO
> import System.Info

> import Control.Applicative
> import Control.Monad

> import GHC.Conc
> import Data.Time.Clock

> import Control.Monad.Trans.State.Strict
> import Control.Monad.Trans.Class

> import Control.Lens

   БОЙЛЕРПЛЕЙТ

> rotate = reverse . transpose

> matrixSize [] = (0, 0)
> matrixSize m = (length (head m), length m)

> randomItem xs = (xs!!) <$> randomRIO (0, length xs - 1)


    РОБОТА З ЧАСОМ

В процесі розробки виявилось, що для роботи з часом потрібні таймери - програмні
структури, що дозволяють відмірювати інтервали часу. Найпростішою такою структурою
виявилась наступна:

> -- | Таймер для відмірювання одного інтервалу
> type Timer = ( Rational  -- ^ показник часу на початок відмірювання
>              , Rational) -- ^ інтервал відмірювання

> -- | Створити новий таймер
> createTimer :: Rational    -- ^ Інтервал часу для таймера
>                -> 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)


    РОБОТА З КЛАВІАТУРОЮ

Для управління грою планувалося використати стандартні функції System.IO, але через баг
GHC на Windows платформах воно не запрацювало як хотілося. Тому була написана альтернативна
реалізація, з використанням нативних консольних функцій conio.h
    
> foreign import ccall unsafe "conio.h getch" c_getch :: IO Char
> foreign import ccall unsafe "conio.h kbhit" c_kbhit :: IO Bool

> getKeyDefault = do hSetEcho stdin False
>                    oldBufferMode <- hGetBuffering stdin
>                    hSetBuffering stdin NoBuffering
>                    ready <- hReady stdin
>                    let result = if ready then Just <$> getChar
>                                          else return Nothing
>                    hSetBuffering stdin oldBufferMode
>                    hSetEcho stdin True
>                    result
> getKeyWindows = do keypressed <- c_kbhit
>                    if keypressed then Just <$> c_getch
>                                  else return Nothing

> -- | Повертає натиснену клавішу або Nothing, якщо нічого не було натиснено.
> -- Платформо-залежна функція
> getKey :: IO (Maybe Char)
> getKey = if os == "mingw32" then getKeyWindows else getKeyDefault


    ІГРОВА ЛОГІКА

Поле для гри зберігається як [[Char]], що є доволі хорошим приближенням до
прямокутної матриці блоків. В такому ж форматі зберігається і фігура, це дає можливість
задати фігури візуально:

> figures = [ [ "##"
>             , "##" ]
>             
>           , [ "####" ]
>           
>           , [ "###"
>             , "#  " ]
>             
>           , [ "###"
>             , "  #" ]
>             
>           , [ "###"
>             , " # " ]
>             
>           , [ " ##"
>             , "## " ]
>             
>           , [ "## "
>             , " ##" ]
>           ]

> emptyLine w = replicate w ' '
> emptyScreen w h = replicate h (emptyLine w)

Більша частина стану гри зберігається у структурі @World.

> data World = World [[Char]]            -- ^ поле гри
>                    (Maybe ( Int        -- ^ координата X фігури
>                           , Int        -- ^ координата Y фігури
>                           , [[Char]])) -- ^ геометрія фігури

> -- | Об'єднати поле гри та фігуру у матрицю символів
> uniteWith :: (Char -> Char -> Char) -> World -> [[Char]]
> uniteWith f (World screen Nothing) = screen
> uniteWith f (World screen (Just (x, y, fig))) = 
>     let ((figW, figH), (scrW, scrH)) = both %~ matrixSize $ (fig, screen)
>         newFig = concat [ emptyScreen scrW y
>                         , (emptyLine x ++).(++ emptyLine (scrW - figW)) <$> fig
>                         , emptyScreen scrW (scrH - figH)
>                         ]
>     in unite' screen newFig
>     where unite' = zipWith (zipWith f)

Цікавить, яка це функція йде першим аргументом @uniteWith ? Ось два приклади:

> -- Логічне І над блоками, дозволяє знайти перетин поля гри та фігури
> and' '#' '#' = '#'
> and'  _   _  = ' '

> -- Логічне АБО над блоками, довзоляє об'єднати фігіру та поле у єдине поле
> or' ' ' ' ' = ' '
> or'  _   _  = '#'

> -- | Поворот фігури проти годинникової
> rotateFigure :: World -> World
> rotateFigure (World screen figure) = World screen ((_3 %~ rotate) <$> figure)

> -- | Переміщення фігури по відносним координатам
> translateFigure :: Int -> Int -> World -> World
> translateFigure dx dy (World screen figure) = World screen ((_1 +~ dx).(_2 +~ dy) <$> figure)

> -- | Вивід поточного світу на консоль.
> showWorld :: World -> IO ()
> showWorld world =
>    let screen = uniteWith or' world
>        border = replicate (length (head screen)) '*' in
>    sequence_ $ putStrLn . ("*" ++).(++ "*") <$> ([border] ++ screen ++ [border])

Щоб взнати, чи може фігура рухатись, потрібно зробити перевірку на перетин, здійснивши
при цьому необхідний рух. Функція @findPossibleMoves вираховує одразу всі можливі варіанти
руху, але, внаслідок лінивості Хаскеля, обчислює їх тільки при необхідності.

> -- | Визначити, які рухи довзолено фігурі в заданій позиції
> findPossibleMoves :: World
>                      -> ( Bool  -- ^ рух вправо
>                         , Bool  -- ^ рух вліво
>                         , Bool  -- ^ рух вниз
>                         , Bool) -- ^ поворот проти годинникової
> findPossibleMoves (World screen Nothing) = (False, False, False, False)
> findPossibleMoves (World screen (Just (x, y, fig))) =
>     let [(figW, figH), (scrW, scrH)] = matrixSize <$> [fig, screen]
>     in ( x > 0                                && doesNotCollide (x-1, y, fig)
>        , x + figW < scrW                      && doesNotCollide (x+1, y, fig)
>        , y + figH < scrH                      && doesNotCollide (x, y+1, fig)
>        , x + figH <= scrW && y + figW <= scrH && doesNotCollide (x, y, rotate fig)
>        ) 
>     where doesNotCollide = all (== ' ') . join . uniteWith and' . World screen . Just

> -- | Об'єднує поле з фігурою та викидує заповнені рядки.
> removeFilledLines :: World 
>                      -> ( [[Char]]  -- ^ об'єднане з фігурою поле гри
>                         , Int)      -- ^ кількість заповнених та видалених рядків
> removeFilledLines world =
>     let screen = uniteWith or' world
>         (scrW, scrH) = matrixSize screen
>         filtered = filter (any (== ' ')) screen
>     in ( emptyScreen scrW (scrH - length filtered) ++ filtered
>        , scrH - length filtered
>        )


    ВЛАСНЕ ГРА

> data GameState = GameState 
>    { _getWorld :: World
>    , _getTimer :: Timer 
>    }

> makeLenses ''GameState

> --modifyWorld f (GameState w t) = GameState (f w) t
> --modifyTimer f (GameState w t) = GameState w (f t)
> modifyWorld f gameState = getWorld %~ f
> modifyTimer f gameState = getTimer %~ f
> 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))

Якщо хтось хоче запустити програму, поставте ghc, потім запустіть ghci

$ghci Prelude> :l path/to/file.lhs
$ghci *Main> main