Game.hs

module Game where

import Data.Array
import System.Random
import Prelude hiding (Either(..))

data Move = Up | Down | Left | Right deriving (Enum)

type Label = Int
type Pos = (Int, Int)
type Board = Array Pos Label

newtype Vec = Vec (Int, Int)

data Game = Game {  emptyField :: Pos
                 ,  gameBoard  :: Board 
                 }  deriving (Eq)

instance Show Game where
  show (Game _ board) = "\n" ++ space ++ line ++ 
                        (foldr (\a b -> a ++ space ++ line ++ b) "\n" $ map column [0 .. 3])
    where post id = showLabel $ board ! id 
          showLabel n  = cell $ show $ case n of
                                        15 -> 0
                                        n  -> n+1
          cell "0"   = "    "
          cell [x]   = ' ':' ': x :' ':[]
          cell [a,b] = ' ': a : b :' ':[] 
          line = "+----+----+----+----+\n"
          nums = ((space ++ "|") ++ ) . foldr (\a b -> a ++ "|" ++ b) "\n". map post
          column i = nums $ map (\x -> (i, x)) [0 .. 3]
          space = "\t"

initGame :: Game
initGame = Game (3, 3) $ listArray ((0, 0), (3, 3)) $ [0 .. 15]

move :: Move -> Game -> Game
move m (Game id board)  
  | within id' = Game id' $ board // updates
  | otherwise  = Game id board
  where id' = shift (orient m) id
        updates = [(id, board ! id'), (id', emptyLabel)] 

within :: Pos -> Bool
within (a, b) = p a && p b
  where p x = x >= 0 && x <= 3

emptyLabel :: Label
emptyLabel = 15

orient :: Move -> Vec
orient m = Vec $ case m of
                  Up    -> ( 1, 0)
                  Down  -> (-1, 0)
                  Left  -> ( 0, 1)
                  Right -> ( 0,-1)

shift :: Vec -> Pos -> Pos
shift (Vec (va, vb)) (pa, pb) = (va + pa, vb + pb)

shuffle :: Int -> IO Game
shuffle n = (iterate (shuffle1 =<<) $ pure initGame) !! n

shuffle1 :: Game -> IO Game
shuffle1 g = flip move g <$> (randomElem $ nextMoves g)

randomElem :: [a] -> IO a
randomElem xs = (xs !! ) <$> randomRIO (0, length xs - 1)

nextMoves :: Game -> [Move]
nextMoves g = filter (within . moveEmptyTo . orient) allMoves
  where moveEmptyTo v = shift v (emptyField g)
        allMoves      = [Up, Down, Left, Right]

Loop.hs

module Loop where

import Game
import Data.Char (isDigit)
import Prelude hiding (Either(..))

data Query = Quit | NewGame Int | Play Move

play :: IO ()
play = greetings >> setup >>= gameLoop

greetings :: IO ()
greetings = putStrLn "Привет! Это игра пятнашки" >> showGame initGame >> remindMoves

showGame :: Game -> IO ()
showGame = putStrLn . show

remindMoves :: IO ()
remindMoves = mapM_ putStrLn talk
  where talk = [  "Возможные ходы:"
                , "   a или l            -- налево"
                , "   d или r            -- направо"
                , "   w или u            -- вверх"
                , "   s или dw           -- вниз"
                , "Другие действия:"
                , "   new int  или n int -- начать новую игру, int - целое число,"
                ,                           "указывающее на сложность"
                , "   quit     или q     -- выход из игры"
                ]

setup :: IO Game
setup = putStrLn "Начнём новую игру?" >>
        putStrLn "Укажите сложность (положительное целое число): " >>
        getLine >>= maybe setup shuffle . readInt 

readInt :: String -> Maybe Int
readInt n 
  | all isDigit n = Just $ read n
  | otherwise     = Nothing

gameLoop :: Game -> IO ()
gameLoop game | isGameOver game = showResults game >> setup >>= gameLoop
              | otherwise       = showGame game >> askForMove >>= reactOnMove game

isGameOver :: Game -> Bool
isGameOver = ( == initGame)

showResults :: Game -> IO ()
showResults g = showGame g >> putStrLn "Игра окончена."

askForMove :: IO Query
askForMove = showAsk >> getLine >>= maybe askAgain return . parseQuery 
  where askAgain = wrongMove >> askForMove

reactOnMove :: Game -> Query -> IO ()
reactOnMove game query = case query of
  Quit      -> quit
  NewGame n -> gameLoop =<< shuffle n
  Play    m -> gameLoop $ move m game

wrongMove :: IO ()
wrongMove = putStrLn "Не могу распознать ход." >> remindMoves

showAsk :: IO ()
showAsk = putStrLn "Ваш ход: "

quit :: IO ()
quit = putStrLn "До встречи." >> return ()

parseQuery :: String -> Maybe Query
parseQuery x = case x of
  "w"     -> Just $ Play Up
  "u"     -> Just $ Play Up
  "s"     -> Just $ Play Down 
  "dw"    -> Just $ Play Down 
  "a"     -> Just $ Play Left
  "l"     -> Just $ Play Left
  "d"     -> Just $ Play Right
  "r"     -> Just $ Play Right
  "quit"  -> Just $ Quit
  "q"     -> Just $ Quit

  'n':'e':'w':' ':n   -> Just . NewGame =<< readInt n
  'n':' ':n           -> Just . NewGame =<< readInt n  
  _       -> Nothing