diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2008, Bertram Felgenhauer + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,14 @@ +This is a Haskell implementation of Programmer's Minesweeper by +John D Ramsdell. See + http://www.ccs.neu.edu/home/ramsdell/pgms +for the original. + +To add a new strategy, create a Haskell module that implements it, and +add it to the list in Strategies.hs. Then add the module itself it the +hs-pgms.cabal file and you're set. Two example strategies are provided, +SimpleStrat.hs and Strat1.hs (actually they're basically the same). + +Note: The hs-pgms executable will launch a GUI by default. Run +hs-pgms --help to see its other capabilities. + +Have fun! diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runghc +> import Distribution.Simple (defaultMain) +> main = defaultMain diff --git a/data/icons.png b/data/icons.png new file mode 100644 Binary files /dev/null and b/data/icons.png differ diff --git a/hs-pgms.cabal b/hs-pgms.cabal new file mode 100644 --- /dev/null +++ b/hs-pgms.cabal @@ -0,0 +1,32 @@ +Name: hs-pgms +Version: 0.1 +Stability: experimental +Copyright: (c) 2008 Bertram Felgenhauer +Maintainer: Bertram Felgenhauer +Category: Game +License: BSD3 +License-File: LICENSE +Synopsis: Programmer's Mine Sweeper in Haskell +Description: + This package allows people to code Minesweeper strategies in Haskell + and run them in a graphical UI. + + Inspired by . +Cabal-Version: >=1.2 +Build-Type: Simple + +-- Data-Dir: data +Data-Files: data/icons.png +Extra-Source-Files: README, statistics + +Library + HS-Source-Dirs: src + Exposed-Modules: Mine + +Executable mine + HS-Source-Dirs: src + Main-is: Main.hs + Other-Modules: Mine, SimpleStrat, Strat1, Util, + GUI, GUI.Common, GUI.Config, GUI.Stats + Build-Depends: base, MonadPrompt, array, mtl, random, glib, gtk, directory + GHC-Options: -threaded diff --git a/src/GUI.hs b/src/GUI.hs new file mode 100644 --- /dev/null +++ b/src/GUI.hs @@ -0,0 +1,225 @@ +-- | +-- Module : GUI +-- Copyright : (c) 2008 Bertram Felgenhauer +-- License : BSD3 +-- +-- Maintainer : Bertram Felgenhauer +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of Haskell PGMS. +-- + +{-# LANGUAGE GADTs, BangPatterns #-} + +module GUI ( + mainGUI, +) where + +import Mine +import Util +import GUI.Common +import GUI.Config +import GUI.Stats + +import qualified Graphics.UI.Gtk as G +import System.Glib.Attributes (AttrOp (..)) +import Control.Monad +import Control.Monad.Prompt +import Data.Maybe +import Data.IORef +import Data.Array.IArray +import System.Random + +backgroundColor :: G.Color +backgroundColor = G.Color 0xE0E0 0xE0E0 0xE0E0 + +frameColor :: G.Color +frameColor = G.Color 0x4040 0x4040 0x4040 + +mainGUI :: [Strategy] -> IO () +mainGUI strats = do + G.unsafeInitGUIForThreadedRTS + mkMainWindow strats + G.mainGUI + +mkMainWindow :: [Strategy] -> IO () +mkMainWindow strats = do + win <- G.windowNew + win `G.set` [G.windowTitle := "Haskell PGMS"] + win `G.onDestroy` G.mainQuit + + vbox <- G.vBoxNew False 0 + win `G.containerAdd` vbox + + menubar <- G.menuBarNew + vbox `G.containerAdd` menubar + + board <- G.drawingAreaNew + vbox `G.containerAdd` board + + statusbar <- G.statusbarNew + vbox `G.containerAdd` statusbar + + state <- newIORef (initState strats) + + let globals = Globals { gBoard = board, + gStatusbar = statusbar, + gState = state } + + configureBoard globals + + runItem <- G.menuItemNewWithLabel "Run" + menubar `G.menuShellAppend` runItem + runMenu <- G.menuNew + runItem `G.menuItemSetSubmenu` runMenu + + runRunItem <- G.menuItemNewWithLabel "Run" + runMenu `G.menuShellAppend` runRunItem + runRunItem `G.onActivateLeaf` runGame globals + + runStatsItem <- G.menuItemNewWithLabel "Statistics..." + runMenu `G.menuShellAppend` runStatsItem + runStatsItem `G.onActivateLeaf` runStats globals + + G.separatorMenuItemNew >>= G.menuShellAppend runMenu + + runQuitItem <- G.menuItemNewWithLabel "Quit" + runMenu `G.menuShellAppend` runQuitItem + runQuitItem `G.onActivateLeaf` G.widgetDestroy win + + difficultyItem <- G.menuItemNewWithLabel "Difficulty" + menubar `G.menuShellAppend` difficultyItem + difficultyMenu <- G.menuNew + difficultyItem `G.menuItemSetSubmenu` difficultyMenu + Just prev <- foldM (\prev (name, cfg) -> do + item <- maybe G.radioMenuItemNewWithLabel + G.radioMenuItemNewWithLabelFromWidget + prev name + item `G.onActivateLeaf` selectConfig item cfg globals + difficultyMenu `G.menuShellAppend` item + return (Just item) + ) Nothing configs + G.separatorMenuItemNew >>= G.menuShellAppend difficultyMenu + customItem <- G.radioMenuItemNewWithLabelFromWidget prev "Custom..." + customItem `G.onActivateLeaf` customConfig customItem globals + difficultyMenu `G.menuShellAppend` customItem + + strategyItem <- G.menuItemNewWithLabel "Strategy" + menubar `G.menuShellAppend` strategyItem + strategyMenu <- G.menuNew + strategyItem `G.menuItemSetSubmenu` strategyMenu + foldM (\prev strat -> do + item <- maybe G.radioMenuItemNewWithLabel + G.radioMenuItemNewWithLabelFromWidget + prev (sName strat) + strategyMenu `G.menuShellAppend` item + item `G.onActivateLeaf` selectStrategy strat globals + return (Just item) + ) Nothing strats + + G.widgetShowAll win + +configureBoard :: Globals -> IO () +configureBoard g = do + let area = gBoard g + + iconFile <- findFile "icons.png" + icons <- G.pixbufNewFromFile iconFile + iconSize <- G.pixbufGetWidth icons + G.widgetSetSizeRequest area (pX maxSize * iconSize + 2) + (pY maxSize * iconSize + 2) + + area `G.onExpose` \_ -> do + s <- readIORef (gState g) + let board = maybe empty id (sBoard s) + makeArray e = listArray (Pos 1 1, cSize (sConfig s)) (repeat e) + empty = Board { + bConfig = sConfig s, + bMines = makeArray False, + bView = makeArray Hidden, + bTodo = 0 } + drawBoard iconSize icons area (sConfig s) board + return True + return () + +drawBoard :: Int -> G.Pixbuf -> G.DrawingArea -> Config -> Board -> IO () +drawBoard iconSize icons area cfg board = do + (w, h) <- G.widgetGetSize area + let Pos sX sY = cSize cfg + ox = (w - sX * iconSize) `div` 2 + oy = (h - sY * iconSize) `div` 2 + draw <- G.widgetGetDrawWindow area + + gc <- G.gcNewWithValues draw G.newGCValues + let drawCell (Pos x y) n = G.drawPixbuf draw gc icons + 0 (n * iconSize) (ox + (x-1)*iconSize) (oy + (y-1)*iconSize) + iconSize iconSize G.RgbDitherNone 0 0 + + forM_ (assocs (bView board)) $ \(p, cell) -> case cell of + Exposed n -> drawCell p n + Hidden -> drawCell p (9 + fromEnum (bMines board ! p)) + Marked -> drawCell p (11 + fromEnum (bMines board ! p)) + Exploded -> drawCell p 13 + + G.gcSetValues gc G.newGCValues { G.foreground = backgroundColor } + G.drawRectangle draw gc False (ox - 1) (oy - 1) + (sX * iconSize + 1) (sY * iconSize + 1) + G.gcSetValues gc G.newGCValues { G.foreground = frameColor } + G.drawRectangle draw gc False (ox - 2) (oy - 2) + (sX * iconSize + 3) (sY * iconSize + 3) + +runGame :: Globals -> IO () +runGame g = do + s <- readIORef (gState g) + maybe runGame' (\_ -> return False) (sStop s) + return () + where + runGame' :: IO Bool + runGame' = do + gen1 <- newStdGen + gen2 <- newStdGen + s <- readIORef (gState g) + runPromptC finish handle (playGameP (sConfig s) gen1 + (sRun (sStrategy s) gen2)) + + handle :: Play a -> (a -> IO Bool) -> IO Bool + handle (Start b) c = do + msg "Start!" + cont c () + setBoard b + handle (Update p b) c = do + cont c () + setBoard b + handle (Trace s b) c = do + cont c () + msg $ "Trace: " ++ s + setBoard b + + finish :: (Result String, Board) -> IO Bool + finish (Won, b) = do + msg "Won!" + setBoard b + finish (Lost, b) = do + msg "Lost!" + setBoard b + finish (Unfinished s, b) = do + msg ("Unfinished: " ++ s) + setBoard b + + cont :: (a -> IO Bool) -> a -> IO () + cont c r = do + hdl <- flip G.timeoutAdd 120 $ do + modifyIORef (gState g) $ \s -> s { sStop = Nothing } + c r + modifyIORef (gState g) $ \s -> s { sStop = Just (G.timeoutRemove hdl) } + + setBoard :: Board -> IO Bool + setBoard b = do + modifyIORef (gState g) $ \s -> s { sBoard = Just b } + G.widgetQueueDraw (gBoard g) + return False + + msg :: String -> IO G.MessageId + msg s = do + G.statusbarPush (gStatusbar g) 1 s diff --git a/src/GUI/Common.hs b/src/GUI/Common.hs new file mode 100644 --- /dev/null +++ b/src/GUI/Common.hs @@ -0,0 +1,54 @@ +-- | +-- Module : GUI.Common +-- Copyright : (c) 2008 Bertram Felgenhauer +-- License : BSD3 +-- +-- Maintainer : Bertram Felgenhauer +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of Haskell PGMS. +-- +-- Common definitions for GUI +-- + +module GUI.Common ( + Globals (..), + State (..), + initState, + maxSize, +) where + +import Mine + +import qualified Graphics.UI.Gtk as G +import Data.IORef + +-- maximum board size supported by GUI +maxSize :: Pos +maxSize = Pos 30 16 + +-- global GUI variables +data Globals = Globals { + gBoard :: G.DrawingArea, + gStatusbar :: G.Statusbar, + gState :: IORef State +} + +-- mutable GUI state +data State = State { + sConfig :: Config, + sStrategy :: Strategy, + sBoard :: Maybe Board, + sStop :: Maybe (IO ()), + sPreviousConfigItem :: Maybe G.RadioMenuItem +} + +-- initial state +initState strats = State { + sConfig = beginner, + sStrategy = head strats, + sBoard = Nothing, + sStop = Nothing, + sPreviousConfigItem = Nothing +} diff --git a/src/GUI/Config.hs b/src/GUI/Config.hs new file mode 100644 --- /dev/null +++ b/src/GUI/Config.hs @@ -0,0 +1,117 @@ +-- | +-- Module : GUI.Config +-- Copyright : (c) 2008 Bertram Felgenhauer +-- License : BSD3 +-- +-- Maintainer : Bertram Felgenhauer +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of Haskell PGMS. +-- +-- Configuration dialogs and menu handlers. +-- + +module GUI.Config ( + configs, + selectStrategy, + selectConfig, + customConfig, +) where + +import Mine +import GUI.Common + +import qualified Graphics.UI.Gtk as G +import Control.Monad +import Data.IORef + +-- list of standard configurations with associated names +configs :: [(String, Config)] +configs = [("Beginner", beginner), + ("Intermediate", intermediate), + ("Expert", expert)] + +-- select a config associated with a menu entry +-- +-- Note: This is also called when changing away from the menu entry. We save +-- the previous config in the `sPreviousConfigItem' state in that case, to +-- be able to reactivate it in `customConfig' if an invalid config is chosen. +selectConfig :: G.RadioMenuItem -> Config -> Globals -> IO () +selectConfig item cfg g = do + active <- G.checkMenuItemGetActive item + if not active then do + modifyIORef (gState g) $ \s -> s { sPreviousConfigItem = Just item } + else do + s <- readIORef (gState g) + when (sConfig s /= cfg) $ do + writeIORef (gState g) s { sConfig = cfg } + resetGame g + G.widgetQueueDraw (gBoard g) + modifyIORef (gState g) $ \s -> s { sPreviousConfigItem = Nothing } + +-- select a custom config +customConfig :: G.RadioMenuItem -> Globals -> IO () +customConfig item g = do + active <- G.checkMenuItemGetActive item + when active $ customConfig' item g + +-- worker for customConfig +customConfig' :: G.RadioMenuItem -> Globals -> IO () +customConfig' item g = do + s <- readIORef (gState g) + let Config { cSize = Pos sX sY, cMines = m } = sConfig s + + -- create dialog + dia <- G.dialogNew + G.windowSetTitle dia "Custom config" + G.dialogAddButton dia G.stockCancel G.ResponseCancel + G.dialogAddButton dia G.stockOk G.ResponseOk + G.dialogSetDefaultResponse dia G.ResponseCancel + + upper <- G.dialogGetUpper dia + table <- G.tableNew 2 3 False + upper `G.containerAdd` table + + -- add input fields + let fs = [("width", 2, sX, pX maxSize), + ("height", 2, sY, pY maxSize), + ("mines", 1, m, 999)] + fields <- forM (zip [0..] fs) $ \(c, (n, l, v, h)) -> do + label <- G.labelNew (Just n) + G.tableAttach table label 0 1 c (c+1) [G.Fill] [] 5 2 + G.miscSetAlignment label 0 0.5 + adj <- G.adjustmentNew (fromIntegral v) l (fromIntegral h) 1 10 10 + button <- G.spinButtonNew adj 0.5 0 + G.tableAttach table button 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2 + return button + + G.widgetShowAll dia + res <- G.dialogRun dia + + [width, height, mines] <- forM fields $ \f -> do + round `liftM` G.spinButtonGetValue f + G.widgetDestroy dia + let cfg' = Config { cSize = Pos width height, + cMines = min (width * height - 1) mines } + case res of + G.ResponseOk -> selectConfig item cfg' g + _ -> do + -- dialog cancelled ... select previous menu entry + case sPreviousConfigItem s of + Just item -> G.checkMenuItemSetActive item True + _ -> return () + +-- select another strategy +selectStrategy :: Strategy -> Globals -> IO () +selectStrategy strat g = do + modifyIORef (gState g) $ \s -> s { sStrategy = strat } + resetGame g + G.widgetQueueDraw (gBoard g) + +-- stop currently playing game - if any +resetGame :: Globals -> IO () +resetGame g = do + s <- readIORef (gState g) + writeIORef (gState g) s { sBoard = Nothing, sStop = Nothing } + maybe (return ()) id (sStop s) diff --git a/src/GUI/Stats.hs b/src/GUI/Stats.hs new file mode 100644 --- /dev/null +++ b/src/GUI/Stats.hs @@ -0,0 +1,158 @@ +-- | +-- Module : GUI.Stats +-- Copyright : (c) 2008 Bertram Felgenhauer +-- License : BSD3 +-- +-- Maintainer : Bertram Felgenhauer +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of Haskell PGMS. +-- +-- Statistics window. Runs a thread for gathering game statistics and displays +-- continuously updating counts. +-- + +{-# LANGUAGE BangPatterns #-} + +module GUI.Stats ( + runStats, +) where + +import Mine +import GUI.Common + +import qualified Graphics.UI.Gtk as G +import System.Glib.Attributes (AttrOp (..)) +import Control.Monad +import Control.Concurrent.MVar +import Control.Concurrent +import System.Random +import Data.IORef +import Numeric + +data Stat = Stat !Int !Int !Int !Int + +-- create window and thread for currently selected board config and strategy +runStats :: Globals -> IO () +runStats g = do + s <- readIORef (gState g) + let strat = sStrategy s + cfg = sConfig s + + -- communication: counters for won, unfinished, lost and total games + counter <- newMVar (Stat 0 0 0 0) + -- the worker works in chunks of this size + chunks <- newMVar 1 + -- the worker sets this MVar when it has new data. + notify <- newMVar () + -- start worker + thread <- forkIO $ gatherStats counter chunks notify strat cfg + + -- create window. display strategy name in the title. + win <- G.windowNew + win `G.set` [G.windowTitle := "Statistics for " ++ sName strat] + + vbox <- G.vBoxNew False 2 + win `G.containerAdd` vbox + + hbox <- G.hBoxNew False 2 + vbox `G.containerAdd` hbox + + -- display information about board configuration + configFrame <- G.frameNew + hbox `G.containerAdd` configFrame + configFrame `G.frameSetLabel` "Board" + + configTable <- G.tableNew 3 2 False + configFrame `G.containerAdd` configTable + let Config { cSize = Pos sX sY, cMines = m } = sConfig s + forM_ (zip3 [0..] ["width", "height", "mines"] [sX, sY, m]) + $ \(c, name, val) -> do + label <- G.labelNew (Just name) + G.miscSetAlignment label 0 0.5 + G.tableAttach configTable label 0 1 c (c+1) [G.Fill] [] 5 2 + label <- G.labelNew (Just (show val)) + G.miscSetAlignment label 1 0.5 + G.tableAttach configTable label 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2 + + -- display running counts + statsFrame <- G.frameNew + hbox `G.containerAdd` statsFrame + statsFrame `G.frameSetLabel` "Statistics" + + statsTable <- G.tableNew 3 3 False + statsFrame `G.containerAdd` statsTable + counters <- forM (zip [0..] ["won", "unfinished", "lost"]) + $ \(c, label) -> do + label <- G.labelNew (Just label) + G.miscSetAlignment label 0 0.5 + G.tableAttach statsTable label 0 1 c (c+1) [G.Fill] [] 5 2 + label2 <- G.labelNew (Just "0") + G.miscSetAlignment label2 1 0.5 + G.tableAttach statsTable label2 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2 + label3 <- G.labelNew (Just "0.00%") + G.miscSetAlignment label3 1 0.5 + G.tableAttach statsTable label3 2 3 c (c+1) [G.Expand, G.Fill] [] 5 2 + return (label2, label3) + + -- provide a button for pausing the worker + button <- G.toggleButtonNewWithLabel "Pause" + vbox `G.containerAdd` button + button `G.onToggled` do + active <- G.toggleButtonGetActive button + if active then takeMVar chunks >> return () else putMVar chunks 1 + + -- callback for updating UI + -- we can't do Gtk+ calls from the worker, so we poll the notify MVar + let update = do + x <- tryTakeMVar notify + case x of + Just () -> do + Stat w u l t <- takeMVar counter + let total = w + u + l + d = total - t + putMVar counter (Stat w u l total) + c <- tryTakeMVar chunks + case c of + Just d' -> do + -- we got d updates, and the previous chunk size was d'. + -- set a new chunk size. + putMVar chunks (maximum [1, d' `div` 2, d `div` 2]) + _ -> return () + -- update the labels in the statistics frame + forM_ (zip [w, u, l] counters) $ \(c, (labelN, labelP)) -> do + labelN `G.labelSetText` show c + when (total > 0) $ do + let pct = 100 * fromIntegral c / fromIntegral total + labelP `G.labelSetText` showGFloat (Just 2) pct "%" + _ -> return () + return True + + timer <- G.timeoutAddFull update G.priorityDefaultIdle 100 + + -- don't forget to clean up when the user closes the window + win `G.onDestroy` do + killThread thread + G.timeoutRemove timer + + G.widgetShowAll win + +-- thread for collecting statistics +gatherStats :: MVar Stat -> MVar Int -> MVar () -> Strategy -> Config -> IO () +gatherStats counter chunks notify strategy cfg = do + n <- readMVar chunks + let stats :: Int -> Int -> Int -> Int -> IO Stat + stats 0 !w !u !l = return (Stat w u l 0) + stats i !w !u !l = do + [gen1, gen2] <- replicateM 2 newStdGen + let (res, _) = playGame cfg gen1 (sRun strategy gen2) + case res of + Won -> stats (i-1) (w+1) u l + Unfinished _ -> stats (i-1) w (u+1) l + Lost -> stats (i-1) w u (l+1) + Stat w u l _ <- stats n 0 0 0 + Stat w' u' l' t' <- takeMVar counter + putMVar counter $! Stat (w + w') (u + u') (l + l') t' + tryPutMVar notify () + gatherStats counter chunks notify strategy cfg diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,238 @@ +-- | +-- Module : Main +-- Copyright : (c) 2008 Bertram Felgenhauer +-- License : BSD3 +-- +-- Maintainer : Bertram Felgenhauer +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of Haskell PGMS. +-- + +{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, BangPatterns #-} + +module Main (main) where + +import Mine +import Util +import GUI +import Strategies + +import System.Random +import Control.Monad.State +import Control.Monad.Prompt +import Control.Concurrent +import Control.Exception +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Data.Char + +-- state for command line processing +data MainState = MainState { + mVerbose :: Bool, -- verbose flag + mIterations :: Int, -- number of iterations for statistics + mStrategy :: Strategy, -- current strategy + mConfig :: Config, -- current config (difficulty) + mRun :: Bool -- has a -r option been seen? +} + +-- initial state +defaultState :: MainState +defaultState = MainState { + mVerbose = False, + mIterations = 1, + mStrategy = head strategies, + mConfig = intermediate, + mRun = True +} + +-- and a state monad to wrap it +newtype Main a = Main { runMain :: StateT MainState IO a} deriving + (Monad, MonadIO, MonadState MainState) + +-- Our main function. getOpt does most of the real work. +main :: IO () +main = do + (acts, extra, errors) <- liftM (getOpt RequireOrder options) getArgs + if not (null extra) || not (null errors) then do + -- wrong arguments? -> display help. + usage + else if null acts then do + -- no arguments? -> run GUI + mainGUI' + else do + -- otherwise process the associated actions for the arguments in order. + evalStateT (runMain (sequence_ acts >> defaultRun)) defaultState + +options :: [OptDescr (Main ())] +options = [ + Option "s" ["strategy"] (ReqArg setStrategy "number") + "Set the current strategy.", + Option "l" ["list"] (NoArg listStrategies) + "List all strategies.", + Option "r" ["run"] (NoArg runGame) + "Run current strategy.", + Option "d" ["difficulty"] (ReqArg setDiff "name") + "Set a standard difficulty level.", + Option "c" ["config"] (ReqArg setConfig "w:h:m") + "Select a custom configuration.", + Option "i" ["iterations"] (ReqArg setIterations "number") + "Set the number of games for --run.", + Option "" ["info"] (NoArg info) + "Display information about current strategy.", + Option "h" ["help"] (NoArg usage') + "Display this help message.", + Option "v" ["verbose"] (NoArg setVerbose) + "Be verbose while running strategies."] + +-- wrapper for mainGUI - we need to run the GUI in a bound thread, and we +-- need to wait for it to finish. this function takes care of that. +mainGUI' :: IO () +mainGUI' = do + finish <- newEmptyMVar + forkOS (finally (mainGUI strategies) (putMVar finish ())) + readMVar finish + +-- list all strategies +listStrategies :: Main () +listStrategies = liftIO $ do + forM_ (zip [1..] strategies) $ \(n, s) -> do + putStrLn (show n ++ ": " ++ sName s) + +-- print help message +usage :: IO () +usage = do + putStr $ usageInfo (formatString "\ + \Usage: mine [OPTION]...\n\ + \The options are processed in order. If no option is given, a GUI \ + \will be displayed. The following options are recognized:") + options + +-- version of usage for the `Main' monad +usage' :: Main () +usage' = do + liftIO usage + modify $ \s -> s { mRun = False } + +-- set strategy +-- strategies can be identified by their number (according to the list above) +-- or by their name. matching is case insensitive in the latter case. +setStrategy :: String -> Main () +setStrategy str = case reads str of + [(i, "")] | i > 0 && i <= length strategies -> do + modify $ \s -> s { mStrategy = strategies !! (i-1) } + _ -> case filter (matchStrategy str) strategies of + [st] -> modify $ \s -> s { mStrategy = st } + _ -> liftIO $ do + hPutStr stderr $ "Unknown strategy '" ++ str ++ "'\n" + exitFailure + where + matchStrategy name strat = map toLower name == map toLower (sName strat) + +-- set number of iterations for statistics gathering +setIterations :: String -> Main () +setIterations str = case reads str of + [(i, "")] | i > 0 -> do + modify $ \s -> s { mIterations = i } + _ -> liftIO $ do + hPutStr stderr $ "Invalid number of iterations '" ++ str ++ "'\n" + exitFailure + +-- set verbose flag +setVerbose :: Main () +setVerbose = do + modify $ \s -> s { mVerbose = True } + +-- set difficulty level +setDiff :: String -> Main () +setDiff str = case lookup (map toLower str) difficulties of + Just cfg -> modify $ \s -> s { mConfig = cfg } + Nothing -> liftIO $ do + hPutStr stderr $ "Unknown difficulty level '" ++ str ++ "'\n" + exitFailure + where + difficulties = [("beginner", beginner), + ("intermediate", intermediate), + ("expert", expert)] + +-- set configuration +setConfig :: String -> Main () +setConfig str = case [ Config (Pos w h) m + | (w, ':' : str') <- reads str, + (h, ':' : str'') <- reads str', + (m, "") <- reads str''] of + [cfg] | validConfig cfg -> do modify $ \s -> s { mConfig = cfg } + | otherwise -> liftIO $ do + hPutStr stderr $ "Invalid config '" ++ str ++ "'\n" + exitFailure + _ -> liftIO $ do + hPutStr stderr $ "Syntax error in config '" ++ str ++ "'\n" + exitFailure + +-- print meta-information of strategy +info :: Main () +info = do + strat <- gets mStrategy + liftIO $ do + putStrLn $ "Strategy name: " ++ sName strat + putStrLn $ "Author : " ++ sAuthor strat + putStr $ "\n" ++ formatString (sDescription strat) + +-- run a game or a series of games +runGame :: Main () +runGame = do + verbose <- gets mVerbose + iter <- gets mIterations + strat <- gets mStrategy + cfg <- gets mConfig + modify $ \s -> s { mRun = False } + + let -- play a single game + runSingleGame :: IO (Result String) + runSingleGame = do + [gen1, gen2] <- replicateM 2 newStdGen + let game = playGameP cfg gen1 (sRun strat gen2) + handle :: Play a -> IO a + handle Start {} = return () + handle Update {} = return () + -- if verbose, print trace messages with board + handle (Trace s b) + | verbose = putStrLn (show b ++ s) + | otherwise = return () + (res, brd) <- runPromptM handle game + -- if verbose, print game result and final board + when verbose $ putStr (show res ++ show brd) + return res + + -- gather statistics for a series of games + stats :: Int -> Int -> Int -> Int -> IO (Int, Int, Int) + stats 0 !w !u !l = return (w, u, l) + stats i !w !u !l = do + res <- runSingleGame + when (verbose && i > 1) $ putStrLn "-----" + case res of + Won -> stats (i-1) (w+1) u l + Unfinished _ -> stats (i-1) w (u+1) l + Lost -> stats (i-1) w u (l+1) + + liftIO $ do + (w, u, l) <- stats iter 0 0 0 + let summary n = show n ++ "/" ++ show (w+u+l) ++ " (" ++ + show (fromIntegral n / fromIntegral (w+u+l) * 100) ++ "%)" + -- print statistics if more than one game was run. + when (iter > 1) $ do + putStrLn $ "Summary for " ++ sName strat + putStrLn $ " won: " ++ summary w + putStrLn $ " lost: " ++ summary l + when (u > 0) $ putStrLn $ " unfinished: " ++ summary u + return () + +-- to make the -r argument optional, we call runGame by default if +-- it has not appeared. +defaultRun :: Main () +defaultRun = do + run <- gets mRun + when run runGame diff --git a/src/Mine.hs b/src/Mine.hs new file mode 100644 --- /dev/null +++ b/src/Mine.hs @@ -0,0 +1,301 @@ +-- | +-- Module : Mine +-- Copyright : (c) 2008 Bertram Felgenhauer +-- License : BSD3 +-- +-- Maintainer : Bertram Felgenhauer +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of Haskell PGMS. +-- +-- It provides types and a monad for implementing and running Minesweeper +-- strategies. It's the core of PGMS. +-- + +{-# LANGUAGE GADTs, FlexibleContexts, Rank2Types, GeneralizedNewtypeDeriving #-} + +module Mine ( + -- * Minesweeper configurations + Config (..), + validConfig, + beginner, + intermediate, + expert, + -- * Minesweeper boards + Pos (..), + Cell (..), + Board (..), + View, + neighbours, + -- * Minesweeper strategies + StrategyM, + Strategy (..), + defaultStrategy, + move, + move_, + mark, + getView, + getConfig, + traceMine, + -- * Running Minesweeper games + Result (..), + playGame, + Play (..), + playGameP, +) where + +import Control.Monad.Prompt +import Control.Monad.State +import Data.Array.IArray +import Data.Array.Unboxed +import System.Random + +-- | A point in 2D space with integer coordinates. +-- +-- Used to adress cells on a Minesweeper board, and also to describe board +-- sizes. +data Pos = Pos { pX :: Int, pY :: Int } deriving (Show, Ord, Eq, Ix) + +-- | A cell on a Minesweeper board. +data Cell = Hidden -- ^ a hidden cell + | Marked -- ^ a marked cell + | Exploded -- ^ oops, you stepped on a mine here! + | Exposed Int -- ^ an exposed cell with a count of neighbours + deriving (Eq, Show) + +-- | A view of the Minesweeper board. +type View = Array Pos Cell + +-- | A complete Minesweeper board, including hidden state. +data Board = Board { + bConfig :: Config, -- ^ board size etc. + bMines :: Array Pos Bool, -- ^ array indicating the position of the mines + bView :: View, -- ^ current view + bTodo :: Int -- ^ number of mines left to find +} + +instance Show Board where + show Board { bConfig = Config { cSize = p }, bMines = b, bView = v } = + '\n' : unlines [ "|" ++ concat [cell (Pos x y) | x <- [1..pX p]] ++ " |" + | y <- [1..pY p]] + where + cell p | b ! p = case v ! p of + Hidden -> " :" + Marked -> " X" + Exploded -> ">%" + | otherwise = case v ! p of + Hidden -> " ." + Marked -> " !" + Exposed 0 -> " " + Exposed i -> ' ' : toEnum (48 + i) : "" + +-- | Description of a mine sweeper configuration (or difficulty). +data Config = Config { + cSize :: Pos, -- ^ the board size + cMines :: Int -- ^ the number of mines placed on the board +} deriving (Eq, Show) + +-- | Check validity of a config. +-- +-- The width and height must be at least 2, and the number of mines must be +-- between 1 and the number of cells on the board, minus 1. +validConfig :: Config -> Bool +validConfig Config { cSize = sz@(Pos sX sY), cMines = m } = + sX >= 2 && sY >= 2 && m >= 1 && m < sX * sY + +-- | Default config: 9x9 with 10 mines +beginner :: Config +beginner = Config { cSize = Pos 9 9, cMines = 10 } + +-- | Default config: 16x16 with 40 mines +intermediate :: Config +intermediate = Config { cSize = Pos 16 16, cMines = 40 } + +-- | Default config: 30x16 with 99 mines +expert :: Config +expert = Config { cSize = Pos 30 16, cMines = 99 } + +-- Create a random board according to the given config. +mkBoard :: Config -> StdGen -> Board +mkBoard cfg@Config { cSize = sz@(Pos sX sY), cMines = m } gen + | not (validConfig cfg) = error "invalid mine config" + | otherwise = Board { + bConfig = cfg, + bView = listArray (Pos 1 1, sz) (repeat Hidden), + bMines = listArray (Pos 1 1, sz) (pick gen (sX * sY) m), + bTodo = sX * sY - m + } + where + pick gen n m | r <= m = True : pick gen' (n-1) (m-1) + | otherwise = False : pick gen' (n-1) m + where + (r, gen') = randomR (1, n) gen + +-- | Find the neighbouring cells of a given cell. +-- +-- The 'Config' parameter is used to find the boundaries of the board. +neighbours :: Config -> Pos -> [Pos] +neighbours Config { cSize = Pos sX sY } (Pos x y) = + [ Pos (x + dx) (y + dy) + | dx <- if x == 1 then [0..1] else if x == sX then [-1..0] else [-1..1], + dy <- if y == 1 then [0..1] else if y == sY then [-1..0] else [-1..1], + dx /= 0 || dy /= 0] + +-- count the mines in the neighbourhood of the given cell +mines :: Board -> Pos -> Int +mines Board { bConfig = cfg, bMines = m } = + length . filter (m !) . neighbours cfg + +data Request a where + Move :: Pos -> Request Int + Mark :: Pos -> Request () + GetView :: Request View + GetConfig :: Request Config + TraceMine :: String -> Request () + +-- | The monad for implementing Minesweeper strategies. +newtype StrategyM a = StrategyM { + runStrategyM :: Prompt Request a +} deriving Monad + +-- | Reveal a cell. Returns the number of mines in the neighbourhood. +-- +-- Note: Revealing a cell with a mine beneath will lose the game. +move :: Pos -> StrategyM Int +move = StrategyM . prompt . Move + +-- | Like 'move', but with no return value. +move_ :: Pos -> StrategyM () +move_ = (>> return ()) . move + +-- | Mark a cell. +-- +-- Note: Marking a cell without a mine beneath will lose the game. This is +-- a deviation from standard Minesweeper. +mark :: Pos -> StrategyM () +mark = StrategyM . prompt . Mark + +-- | Get a view of the current board. +getView :: StrategyM View +getView = StrategyM (prompt GetView) + +-- | Get the current board's config. +-- +-- Note: the config will never change throughout a game. +getConfig :: StrategyM Config +getConfig = StrategyM (prompt GetConfig) + +-- | Provide a debug message. +-- +-- These will be displayed in the status line in the GUI or on the +-- terminal when running the command line version in verbose mode. +traceMine :: String -> StrategyM () +traceMine = StrategyM . prompt . TraceMine + +-- | A game result. +data Result a = Won -- ^ The game was won. + | Unfinished a -- ^ The strategy implementation finished + -- before the game was over. + | Lost -- ^ The game was lost. + deriving (Show, Eq) + +-- | A strategy with some meta-information. +-- +-- It's advisable to define your own strategies in terms of 'defaultStrategy' +-- so that future additions to that record don't break your code. +data Strategy = Strategy { + sName :: String, -- ^ The strategy's name. It should be ASCII + -- and not contain spaces. + sAuthor :: String, -- ^ The strategy's author. + sDescription :: String, -- ^ A description of the strategy. + sRun :: StdGen -> StrategyM String + -- ^ The strategy's implementation. +} + +-- | Default values for 'Strategy'. +-- +-- > myStrategy :: Strategy +-- > myStrategy = defaultStrategy { +-- > sName = "Hiho", +-- > sRun = \_ -> return "I don't want to play anymore, see you!" +-- > } +defaultStrategy :: Strategy +defaultStrategy = Strategy { + sName = "", + sAuthor = "", + sDescription = "This strategy has no description.", + sRun = \_ -> return "" +} + +-- | UI interface +-- +-- These are actions for the 'MonadPrompt' monad. +-- +-- * 'Start' - A new game just started. +-- +-- * 'Update' - A move was made, and the indicated cell changed +-- +-- * 'Trace' - The strategy provided a trace message. +-- +data Play a where + Start :: Board -> Play () -- (^ A new game just started. + Update :: Pos -> Board -> Play () + -- (^ A move was made, and the indicated cell + -- changed + Trace :: String -> Board -> Play () + -- (^ The strategy provided a trace message. + +-- internally, we work in this monad. +type PlayM a = StateT Board (Prompt Play) (Result a) + +-- | Play a game. +-- +-- The result is a 'Prompt' action, which is suitable for implementing +-- a UI that displays the game's progress. +playGameP :: Config -> StdGen -> StrategyM a -> Prompt Play (Result a, Board) +playGameP cfg gen strategy = runStateT (game strategy) (mkBoard cfg gen) + where + game :: StrategyM a -> PlayM a + game strategy = do + get >>= lift . prompt . Start + runPromptC (return . Unfinished) handle (runStrategyM strategy) + + handle :: Request p -> (p -> PlayM a) -> PlayM a + handle GetView cont = gets bView >>= cont + handle GetConfig cont = gets bConfig >>= cont + handle (Move p) cont = do + b@Board { bMines = bm, bView = bv, bTodo = bt } <- get + if bm ! p then do put b { bView = bv // [(p, Exploded)] } + get >>= lift . prompt . Update p + return Lost + else case bv ! p of + Exposed i -> cont i + _ -> do let n = mines b p + put b { bView = bv // [(p, Exposed n)], + bTodo = bt - 1 } + get >>= lift . prompt . Update p + if bt == 1 then return Won else cont n + handle (Mark p) cont = do + b@Board { bMines = bm, bView = bv } <- get + when (bv ! p == Hidden) $ do + put b { bView = bv // [(p, Marked)] } + get >>= lift . prompt . Update p + if bm ! p then + cont () + else + return Lost + handle (TraceMine s) cont = get >>= lift . prompt . Trace s >> cont () + +-- | A pure version of 'playGameP'. +playGame :: Config -> StdGen -> StrategyM a -> (Result a, Board) +playGame cfg gen strat = runPrompt handle (playGameP cfg gen strat) where + handle :: Play a -> a + handle Start {} = () + handle Update {} = () + handle (Trace s b) = () + +{- +example won game: +playGame True beginner (mkStdGen 164806687) (mark (Pos 9 1) >> mark (Pos 3 4) >> mark (Pos 5 4) >> mark (Pos 1 5) >> mark (Pos 5 5) >> mark (Pos 9 5) >> mark (Pos 1 8) >> mark (Pos 3 8) >> mark (Pos 8 8) >> mark (Pos 3 9) >> getView >>= \l -> sequence [move p | (p, Hidden) <- assocs l]) +-} diff --git a/src/SimpleStrat.hs b/src/SimpleStrat.hs new file mode 100644 --- /dev/null +++ b/src/SimpleStrat.hs @@ -0,0 +1,59 @@ +-- | +-- Module : SimpleStrat +-- Copyright : (c) 2008 Bertram Felgenhauer +-- License : BSD3 +-- +-- Maintainer : Bertram Felgenhauer +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of Haskell PGMS. +-- +-- Another simple minesweeper strategy. +-- + +module SimpleStrat (simpleStrat) where + +import Mine + +import Data.Array.IArray +import System.Random +import Control.Monad + +simpleStrat :: Strategy +simpleStrat = defaultStrategy { + sName = "SimpleStrat", + sAuthor = "Bertram Felgenhauer ", + sDescription = + "This strategy makes inferences from exposed cells and their immediate \ + \neighbourhood, and picks a random cell if no inference can be made.\n\ + \It should be equivalent to the PGMS Single Point Strategy.", + sRun = \s -> getConfig >>= flip worker s +} + +worker :: Config -> StdGen -> StrategyM String +worker cfg gen = do + view <- getView + let actions = scan cfg view + if null actions then randomMove cfg view gen >>= worker cfg + else sequence_ actions >> worker cfg gen + +randomMove :: Config -> View -> StdGen -> StrategyM StdGen +randomMove cfg@Config { cSize = Pos sX sY } view gen = let + (x, gen') = randomR (1, sX) gen + (y, gen'') = randomR (1, sY) gen' + p = Pos x y + in + if view ! p == Hidden then move p >> return gen'' + else randomMove cfg view gen'' + +scan :: Config -> View -> [StrategyM ()] +scan cfg view = concat + [ moves + | (p, Exposed num) <- assocs view, + let ns = neighbours cfg p + ms = [n | n <- ns, view ! n == Marked] + us = [n | n <- ns, view ! n == Hidden] + moves | num == length ms = [move_ n | n <- us] + | num == length ms + length us = [mark n | n <- us] + | otherwise = []] diff --git a/src/Strat1.hs b/src/Strat1.hs new file mode 100644 --- /dev/null +++ b/src/Strat1.hs @@ -0,0 +1,60 @@ +-- | +-- Module : Strat1 +-- Copyright : (c) 2008 Bertram Felgenhauer +-- License : BSD3 +-- +-- Maintainer : Bertram Felgenhauer +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of Haskell PGMS. +-- +-- A simple minesweeper strategy. +-- + +module Strat1 (strat1) where + +import Mine + +import Data.Array.IArray +import System.Random + +strat1 :: Strategy +strat1 = defaultStrategy { + sName = "Strategy1", + sAuthor = "Bertram Felgenhauer ", + sDescription = + "A first attempt at implementing the Single Point Strategy. It's \ + \missing some forced inferences though.", + sRun = \s -> getConfig >>= \c -> worker c s +} + +worker :: Config -> StdGen -> StrategyM String +worker cfg@Config { cSize = Pos sX sY } gen = worker' gen [] + where + worker' :: StdGen -> [Pos] -> StrategyM String + worker' gen [] = do + vw <- getView + let (x, gen') = randomR (1, sX) gen + (y, gen'') = randomR (1, sY) gen' + p = Pos x y + if vw ! p == Hidden then + move p >> worker' gen'' [p] + else + worker' gen'' [] + worker' gen (p : ps) = do + vw <- getView + let Exposed i = vw ! p + a = neighbours cfg p + m = [q | q <- a, Marked <- [vw ! q]] + u = [q | q <- a, Hidden <- [vw ! q]] + if length m == i then do + mapM_ move u + worker' gen ([r | q <- u, r <- neighbours cfg q, + Exposed _ <- [vw ! r]] ++ u ++ ps) + else if length u + length m == i then do + mapM_ mark u + worker' gen ([r | q <- u, r <- neighbours cfg q, + Exposed _ <- [vw ! r]] ++ ps) + else + worker' gen ps diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,53 @@ +-- | +-- Module : Util +-- Copyright : (c) 2008 Bertram Felgenhauer +-- License : BSD3 +-- +-- Maintainer : Bertram Felgenhauer +-- Stability : experimental +-- Portability : portable +-- +-- This module is part of Haskell PGMS. +-- +-- Miscellaneous utility functions +-- + +module Util ( + findFile, + formatString +) where + +import Paths_hs_pgms + +import System.Directory +import Data.Char +import Data.List + +-- find a data file +-- this uses Paths_mine.getDataFileName, but also looks +-- in a few other places for convenient in-place running. +findFile :: FilePath -> IO FilePath +findFile name = do + let scan :: [IO FilePath] -> IO FilePath + scan [] = error $ "Couldn't find file '" ++ name ++ "'" + scan (c:cs) = do + f <- c + b <- doesFileExist f + if b then return f else scan cs + scan [getDataFileName $ "data/" ++ name, + return $ "data/" ++ name, + return $ "../data/" ++ name, + return $ name] + +-- format a text string to fit nicely into 78 columns of text. +formatString :: String -> String +formatString = unlines . concatMap (block . (++" ")) . intersperse "" . lines + where + block "" = [] + block text = let + (chunk, rest) = splitAt 78 text + (end', start') = span (not . isSpace) (reverse chunk) + in + if null start' then chunk : block (dropWhile isSpace rest) + else reverse (dropWhile isSpace start') + : block (reverse end' ++ rest) diff --git a/statistics b/statistics new file mode 100644 --- /dev/null +++ b/statistics @@ -0,0 +1,29 @@ +================================= [Beginner] ================================= + +Summary for Strategy1 + won: 55637/100000 (55.637%) + lost: 44363/100000 (44.363%) + +Summary for SimpleStrat + won: 59822/100000 (59.822%) + lost: 40178/100000 (40.178%) + +=============================== [Intermediate] =============================== + +Summary for Strategy1 + won: 24293/100000 (24.293%) + lost: 75707/100000 (75.707%) + +Summary for SimpleStrat + won: 30167/100000 (30.167%) + lost: 69833/100000 (69.833%) + +================================== [Expert] ================================== + +Summary for Strategy1 + won: 307/100000 (0.307%) + lost: 99693/100000 (99.693%) + +Summary for SimpleStrat + won: 690/100000 (0.69%) + lost: 99310/100000 (99.31%)