SHARE
TWEET

Game.hs

a guest Sep 18th, 2019 85 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. {-# LANGUAGE TemplateHaskell #-}
  2. {-# LANGUAGE GADTs #-}
  3.  
  4. module Game
  5.     (   Board
  6.     ,   Cell (..)
  7.     ,   Cells (..)
  8.     ,   CntEmpty
  9.     ,   Dummy (..)
  10.     ,   Game (..)
  11.     ,   Pos
  12.  
  13.     -- game params    
  14.     ,   height
  15.     ,   width
  16.  
  17.     -- initial game state
  18.     ,   startGame
  19.    
  20.     -- State
  21.     ,   move
  22.     ,   showHelp
  23.     ,   showRules
  24.  
  25.     --lenses
  26.     ,   gameBoard
  27.     ,   isOver
  28.     ,   msg
  29.     ,   player
  30.     ,   textDisplay
  31.     )   where
  32.  
  33. import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
  34. import Control.Monad (guard)
  35. import Control.Monad.State (State)
  36. import Data.Array (Array, listArray, (//), (!), elems )
  37. import Data.List (group, length)
  38. import Control.Lens ((.=), makeLenses, use)
  39.  
  40. type Pos = (Int, Int)
  41.  
  42. instance Ord (Cell a) where
  43.     (<=) (Chip _) (Chip _) = True
  44.     (<=) Empty Empty = True
  45.  
  46. data Color = Red | Yellow  deriving (Eq, Show)
  47. data Dummy = Dummy
  48.  
  49. data Cell a where
  50.     Empty  :: Cell Dummy
  51.     Chip :: Bool -> Cell Color
  52.  
  53. instance Show (Cell a) where
  54.     (show) (Empty) = "Empty"
  55.     (show) (Chip False) = "Chip Yellow"
  56.     (show) (Chip True) = "Chip Red"
  57.  
  58. instance Eq (Cell a) where
  59.     (==) (Empty) (Empty) = True
  60.     (==) (Chip x) (Chip y) = (x == y)
  61.  
  62. data Cells = EmptyCell (Cell Dummy) | ChipCell  (Cell Color) deriving (Eq, Show, Ord)
  63.  
  64. type Board = Array Pos (Cells)
  65. type CntEmpty = Array Int Int
  66.  
  67. width, height :: Int
  68. width = 7
  69. height = 6
  70.  
  71.  
  72. data Game = Game {
  73.         _gameBoard :: Board
  74.     ,   _emptyTracker :: CntEmpty
  75.     ,   _player :: Bool
  76.     ,   _isOver :: Int
  77.     ,   _textDisplay :: [String]
  78.     ,   _msg :: String
  79.     } deriving (Eq, Show)
  80.  
  81. makeLenses ''Game
  82.    
  83.  
  84. --только последний ход мог повлиять
  85. isWinner :: Board -> Pos -> Int
  86. isWinner b (i, j) = winner (map winnerInRow genSubLists)
  87.     where
  88.         --находит победителя вообще
  89.         winner :: [Int] -> Int
  90.         winner = maximum
  91.  
  92.         --находит победителя в строке
  93.         winnerInRow :: [Cells] -> Int
  94.         winnerInRow r = res
  95.             where
  96.                 a_ = group r
  97.                 b_ = map length a_
  98.                 (cnt, (x : _)) = maximum $ zip b_ a_
  99.                 res
  100.                     | cnt >= 4 = cellToNum x
  101.                     | otherwise = 0
  102.  
  103.         --генерирует подстроки
  104.         genSubLists :: [[Cells]]
  105.         genSubLists =  map (map value)
  106.             [  zip x $ repeat j
  107.             ,  zip (repeat i) y
  108.             ,  zip x y
  109.             ,  zip (reverse x) y]
  110.  
  111.             where
  112.                 x =  [i - 3 .. i + 3]
  113.                 y =  [j - 3 .. j + 3]
  114.  
  115.         value :: Pos -> Cells
  116.         value p
  117.             | inside p = b ! p
  118.             | otherwise = EmptyCell $ Empty
  119.  
  120.         inside :: Pos -> Bool
  121.         inside (l, r) =
  122.             (l >= 0) && (r >= 0) && (l < width) && (r < height)
  123.  
  124.         cellToNum :: Cells -> Int
  125.         cellToNum x =  case x of
  126.                 ChipCell (Chip False) -> 1
  127.                 ChipCell (Chip True) -> 2
  128.                 EmptyCell _ -> 0
  129.  
  130.  
  131.  
  132. isGameOver :: Int -> CntEmpty -> Board ->  Int
  133. isGameOver lastmove ind gb =
  134.     if (noMoves ind)
  135.     then 3
  136.     else isWinner gb (lastmove, indLastMove)
  137.     where
  138.         indLastMove :: Int
  139.         indLastMove =  (height - ind ! lastmove) - 1
  140.  
  141.         noMoves :: CntEmpty -> Bool
  142.         noMoves l = all ( == 0) (elems l)
  143.  
  144. playerToNum :: Bool -> Int
  145. playerToNum False = 1
  146. playerToNum True = 2  
  147.  
  148.  
  149. showHelp :: State Game ()
  150. showHelp = do
  151.     p <- use player
  152.     textDisplay .= help ++ [("Player " ++ (show . playerToNum) p)]
  153.     where
  154.         help :: [String]
  155.         help = ["I can help you", "Click blue buttons to" , " make a move","If you don't know ",
  156.             " rules, click orange button", "If you want to start a new"," game, click green button"
  157.             ,"", "And now the turn of"]
  158.  
  159. showRules :: State Game ()
  160. showRules = do
  161.     p <- use player
  162.     textDisplay .= rules ++ [("Player " ++ (show . playerToNum) p)]
  163.     where
  164.         rules :: [String]
  165.         rules =
  166.             ["(c) Wikipeadia", " \"Four in a row\" is a ", "two-player connection game ", "in which the players first"
  167.             ,"choose a color and then", "take turns dropping one","colored disc from the top"
  168.             ,"into a seven-column, six-", "row vertically suspended grid.", " The pieces fall straight",
  169.             "down, occupying the lowest ", "available space within the ", "column."
  170.             , " The objective of the game", "is to be the first to form ", "a horizontal, vertical, or "
  171.             , "diagonal line of four of ", "one's own discs."
  172.             ,"", "And now the turn of"]
  173.  
  174. move :: Int -> State Game Int
  175. move p = do
  176.     res <- runMaybeT (moveT p)
  177.     case res of
  178.         Nothing -> do
  179.             msg .= "Column overflow"
  180.             return (-1)
  181.         Just 0 -> do
  182.             msg.=""
  183.             return 0
  184.         Just res' -> do
  185.            msg .= "Game over"
  186.            return res'
  187.  
  188. moveT :: Int -> MaybeT (State Game) Int
  189. moveT pos = do
  190.     p <- use player
  191.     ind <- use emptyTracker
  192.     gb <- use gameBoard
  193.  
  194.     let okPos = (pos >= 0) && (pos < width) && (ind ! pos > 0)
  195.     guard $ okPos
  196.  
  197.     let ypos = (height - ind ! pos)
  198.     let curCh = gb ! (pos, ypos )
  199.     let isOk = q where
  200.         q = case curCh of
  201.             ChipCell _ -> Nothing
  202.             EmptyCell x -> Just x
  203.     guard $ (isOk /= Nothing)
  204.  
  205.     gameBoard .=  gb // [((pos,  ypos), newChip p isOk)]
  206.     emptyTracker .= ind // [(pos, ind ! pos - 1)]
  207.     player .= not p
  208.     curInd <- use emptyTracker
  209.     curGb <- use gameBoard
  210.  
  211.     let ov = isGameOver pos curInd curGb
  212.     isOver .= ov
  213.  
  214.     if (ov == 0)
  215.     then textDisplay .=  ["And now the turn of", "Player "++ show(playerToNum (not p))]
  216.     else textDisplay .=  ["Game over", (winText ov) ,"Do you want to start", "  a new game?"]
  217.     return ov
  218.  
  219.     where
  220.         winText ov = case ov of
  221.             1 -> "Player 1 won"
  222.             2 -> "Player 2 won"
  223.             3 -> "Draw"
  224.             _ -> ""
  225.         newChip :: Bool -> Maybe (Cell Dummy) -> Cells
  226.         newChip p (Just _) = ChipCell (Chip p)
  227.         newChip _ _ = EmptyCell (Empty)
  228.  
  229. startGame :: Game
  230. startGame = Game newField newEmptyTracker newPlayer 0
  231.     ["Welcome to the game "
  232.     , "    \"4 in a row\""
  233.     , "If you need some help,"
  234.     , "   click on pink button"
  235.     , "","And now the turn of"
  236.     ,  "Player 1"]
  237.     ""
  238.     where
  239.         newField = listArray ((0, 0), (width - 1, height - 1)) $ map EmptyCell (replicate (width * height) Empty)
  240.         newEmptyTracker = listArray (0, width - 1) $ (replicate (width) height)
  241.         newPlayer = False
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top