Game.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs #-}

module Game
    (   Board
    ,   Cell (..)
    ,   Cells (..)
    ,   CntEmpty
    ,   Dummy (..)
    ,   Game (..)
    ,   Pos

    -- game params
    ,   height
    ,   width

    -- initial game state
    ,   startGame

    -- State
    ,   move
    ,   showHelp
    ,   showRules

    --lenses
    ,   gameBoard
    ,   isOver
    ,   msg
    ,   player
    ,   textDisplay
    )   where

import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import Control.Monad (guard)
import Control.Monad.State (State)
import Data.Array (Array, listArray, (//), (!), elems )
import Data.List (group, length)
import Control.Lens ((.=), makeLenses, use)

type Pos = (Int, Int)

instance Ord (Cell a) where
    (<=) (Chip _) (Chip _) = True
    (<=) Empty Empty = True

data Color = Red | Yellow  deriving (Eq, Show)
data Dummy = Dummy

data Cell a where
    Empty  :: Cell Dummy
    Chip :: Bool -> Cell Color

instance Show (Cell a) where
    (show) (Empty) = "Empty"
    (show) (Chip False) = "Chip Yellow"
    (show) (Chip True) = "Chip Red"

instance Eq (Cell a) where
    (==) (Empty) (Empty) = True
    (==) (Chip x) (Chip y) = (x == y)

data Cells = EmptyCell (Cell Dummy) | ChipCell  (Cell Color) deriving (Eq, Show, Ord)

type Board = Array Pos (Cells)
type CntEmpty = Array Int Int

width, height :: Int
width = 7
height = 6


data Game = Game {
        _gameBoard :: Board
    ,   _emptyTracker :: CntEmpty
    ,   _player :: Bool
    ,   _isOver :: Int
    ,   _textDisplay :: [String]
    ,   _msg :: String
    } deriving (Eq, Show)

makeLenses ''Game


--только последний ход мог повлиять
isWinner :: Board -> Pos -> Int
isWinner b (i, j) = winner (map winnerInRow genSubLists)
    where
        --находит победителя вообще
        winner :: [Int] -> Int
        winner = maximum

        --находит победителя в строке
        winnerInRow :: [Cells] -> Int
        winnerInRow r = res
            where
                a_ = group r
                b_ = map length a_
                (cnt, (x : _)) = maximum $ zip b_ a_
                res
                    | cnt >= 4 = cellToNum x
                    | otherwise = 0

        --генерирует подстроки
        genSubLists :: [[Cells]]
        genSubLists =  map (map value)
            [  zip x $ repeat j
            ,  zip (repeat i) y
            ,  zip x y
            ,  zip (reverse x) y]

            where
                x =  [i - 3 .. i + 3]
                y =  [j - 3 .. j + 3]

        value :: Pos -> Cells
        value p
            | inside p = b ! p
            | otherwise = EmptyCell $ Empty

        inside :: Pos -> Bool
        inside (l, r) =
            (l >= 0) && (r >= 0) && (l < width) && (r < height)

        cellToNum :: Cells -> Int
        cellToNum x =  case x of
                ChipCell (Chip False) -> 1
                ChipCell (Chip True) -> 2
                EmptyCell _ -> 0



isGameOver :: Int -> CntEmpty -> Board ->  Int
isGameOver lastmove ind gb =
    if (noMoves ind)
    then 3
    else isWinner gb (lastmove, indLastMove)
    where
        indLastMove :: Int
        indLastMove =  (height - ind ! lastmove) - 1

        noMoves :: CntEmpty -> Bool
        noMoves l = all ( == 0) (elems l)

playerToNum :: Bool -> Int
playerToNum False = 1
playerToNum True = 2


showHelp :: State Game ()
showHelp = do
    p <- use player
    textDisplay .= help ++ [("Player " ++ (show . playerToNum) p)]
    where
        help :: [String]
        help = ["I can help you", "Click blue buttons to" , " make a move","If you don't know ",
            " rules, click orange button", "If you want to start a new"," game, click green button"
            ,"", "And now the turn of"]

showRules :: State Game ()
showRules = do
    p <- use player
    textDisplay .= rules ++ [("Player " ++ (show . playerToNum) p)]
    where
        rules :: [String]
        rules =
            ["(c) Wikipeadia", " \"Four in a row\" is a ", "two-player connection game ", "in which the players first"
            ,"choose a color and then", "take turns dropping one","colored disc from the top"
            ,"into a seven-column, six-", "row vertically suspended grid.", " The pieces fall straight",
            "down, occupying the lowest ", "available space within the ", "column."
            , " The objective of the game", "is to be the first to form ", "a horizontal, vertical, or "
            , "diagonal line of four of ", "one's own discs."
            ,"", "And now the turn of"]

move :: Int -> State Game Int
move p = do
    res <- runMaybeT (moveT p)
    case res of
        Nothing -> do
            msg .= "Column overflow"
            return (-1)
        Just 0 -> do
            msg.=""
            return 0
        Just res' -> do
            msg .= "Game over"
            return res'

moveT :: Int -> MaybeT (State Game) Int
moveT pos = do
    p <- use player
    ind <- use emptyTracker
    gb <- use gameBoard

    let okPos = (pos >= 0) && (pos < width) && (ind ! pos > 0)
    guard $ okPos

    let ypos = (height - ind ! pos)
    let curCh = gb ! (pos, ypos )
    let isOk = q where
        q = case curCh of
            ChipCell _ -> Nothing
            EmptyCell x -> Just x
    guard $ (isOk /= Nothing)

    gameBoard .=  gb // [((pos,  ypos), newChip p isOk)]
    emptyTracker .= ind // [(pos, ind ! pos - 1)]
    player .= not p
    curInd <- use emptyTracker
    curGb <- use gameBoard

    let ov = isGameOver pos curInd curGb
    isOver .= ov

    if (ov == 0)
    then textDisplay .=  ["And now the turn of", "Player "++ show(playerToNum (not p))]
    else textDisplay .=  ["Game over", (winText ov) ,"Do you want to start", "  a new game?"]
    return ov

    where
        winText ov = case ov of
            1 -> "Player 1 won"
            2 -> "Player 2 won"
            3 -> "Draw"
            _ -> ""
        newChip :: Bool -> Maybe (Cell Dummy) -> Cells
        newChip p (Just _) = ChipCell (Chip p)
        newChip _ _ = EmptyCell (Empty)

startGame :: Game
startGame = Game newField newEmptyTracker newPlayer 0
    ["Welcome to the game "
    , "    \"4 in a row\""
    , "If you need some help,"
    , "   click on pink button"
    , "","And now the turn of"
    ,  "Player 1"]
    ""
    where
        newField = listArray ((0, 0), (width - 1, height - 1)) $ map EmptyCell (replicate (width * height) Empty)
        newEmptyTracker = listArray (0, width - 1) $ (replicate (width) height)
        newPlayer = False