Advertisement
Yurry

Haskell Minesweeper for Habrahabr

Feb 3rd, 2015
1,070
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. import Data.Map
  2. import Data.Set
  3. import Graphics.Gloss
  4. import Graphics.Gloss.Data.ViewPort
  5. import Graphics.Gloss.Interface.Pure.Game
  6. import System.Random
  7. import System.Random.Shuffle (shuffle')
  8.  
  9. main :: IO ()
  10. main = do
  11.    gen <- getStdGen
  12.    startGame gen
  13.  
  14. fieldSize@(fieldWidth, fieldHeight) = (15, 15) :: (Int, Int)
  15. mineCount = 40 :: Int
  16.  
  17. createField :: Field
  18. createField = Data.Map.empty
  19.  
  20. type Field = Map Cell CellState --не забудем дописать вначале import Data.Map
  21. type Cell = (Int, Int)
  22.  
  23. data CellState = Opened Int --Открыта; параметр — циферка, которая будет отображаться
  24.               | Mine       --Подорвались; без параметров
  25.               | Flag       --Поставлен флажок
  26.  
  27. type Mines = Set Cell
  28.  
  29. createMines :: RandomGen g => g -> Cell -> Mines
  30. createMines g fst = Data.Set.fromList $ take mineCount $ shuffle g $
  31.    [(i, j) | i <- [0 .. fieldWidth - 1]
  32.            , j <- [0 .. fieldHeight - 1]
  33.            , (i, j) /= fst]
  34.  
  35. shuffle g l = shuffle' l (fieldWidth * fieldHeight - 1) g
  36.  
  37. data GameState = GS
  38.     { field    :: Field
  39.     , mines    :: Either StdGen Mines
  40.     , gameOver :: Bool
  41.     }
  42.  
  43. startGame :: StdGen -> IO ()
  44. startGame gen = play (InWindow "Hsweeper" windowSize (240, 160)) white 30 (initState gen) renderer handler updater
  45.  
  46. windowSize = both (* (round cellSize)) fieldSize
  47. cellSize = 24 :: Float
  48.  
  49. initState gen = GS createField (Left gen) False
  50.  
  51. both :: (a -> b) -> (a, a) -> (b, b)
  52. both f (a, b) = (f a, f b) --вспомогательная функция, которая ещё пригодится
  53.  
  54. updater _ = id
  55.  
  56. cellToScreen = both ((* cellSize) . fromIntegral)
  57.  
  58. handler (EventKey (MouseButton LeftButton) Down _ mouse) gs@GS
  59.     { mines = Left gen
  60.     } = gs { mines = Right $ createMines gen cell } where
  61.     cell = screenToCell mouse
  62.  
  63. handler (EventKey (MouseButton LeftButton) Down _ mouse) gs@GS
  64.     { field = field
  65.     , mines = Right mines
  66.     , gameOver = False
  67.     } = gs
  68.     { field = newField
  69.     , gameOver = exploded
  70.     } where
  71.     newField = click cell field
  72.     exploded = case Data.Map.lookup cell newField of --Проигрыш, если последняя вскрытая клетка - мина
  73.         Just Mine -> True
  74.         _         -> False
  75.     cell@(cx, cy) = screenToCell mouse
  76.     click :: Cell -> Field -> Field
  77.     click c@(cx, cy) f
  78.         | c `Data.Map.member` f     = f --повторно клетку не обрабатываем
  79.         | c `Data.Set.member` mines = put Mine --попались на мину
  80.         | otherwise = let nf = put (Opened neighbours) in
  81.             if neighbours == 0
  82.                 then Prelude.foldr click nf neighbourCells --Обойдём соседей
  83.                 else nf
  84.         where
  85.             put state = Data.Map.insert c state f
  86.             neighbourCells = [ (i, j) | i <- [cx - 1 .. cx + 1], j <- [cy - 1 .. cy + 1]
  87.                              , 0 <= i && i < fieldWidth
  88.                              , 0 <= j && j < fieldHeight
  89.                              ] --Жаль, нельзя написать 0 <= i < fieldWidth
  90.             neighbours = length $ Prelude.filter (`Data.Set.member` mines) neighbourCells
  91.  
  92.  
  93. handler (EventKey (MouseButton RightButton) Down _ mouse) gs@GS
  94.     { field = field
  95.     } = case Data.Map.lookup coord field of
  96.         Nothing -> gs { field = Data.Map.insert coord Flag field }
  97.         Just Flag -> gs { field = Data.Map.delete coord field }
  98.         _ -> gs
  99.         where coord = screenToCell mouse
  100. handler _ gs = gs
  101. screenToCell = both (round . (/ cellSize)) . invertViewPort viewPort
  102.  
  103. renderer GS { field = field } = applyViewPortToPicture viewPort $ pictures $ cells ++ grid where
  104.     grid = [uncurry translate (cellToScreen (x, y)) $ color black $ rectangleWire cellSize cellSize | x <- [0 .. fieldWidth - 1], y <- [0 .. fieldHeight - 1]]
  105.     cells = [uncurry translate (cellToScreen (x, y)) $ drawCell x y | x <- [0 .. fieldWidth - 1], y <- [0 .. fieldHeight - 1]]
  106.     drawCell x y = case Data.Map.lookup (x, y) field of
  107.         Nothing         -> color white $ rectangleSolid cellSize cellSize --клетка пустая
  108.         Just Mine       -> pictures [ color red $ rectangleSolid cellSize cellSize
  109.                                     , label "@"
  110.                                     ]
  111.         Just (Opened n) -> pictures [ color green $ rectangleSolid cellSize cellSize
  112.                                     , label $ show n
  113.                                     ]
  114.         Just Flag       -> pictures [ color yellow $ rectangleSolid cellSize cellSize
  115.                                     , label "?"
  116.                                     ]
  117.     label = translate (-5) (-5) . scale 0.15 0.15 . color black . text
  118.  
  119. viewPort = ViewPort (both (negate . (/ 2) . (subtract cellSize)) $ cellToScreen fieldSize) 0 1
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement