packages feed

hs-pgms (empty) → 0.1

raw patch · 15 files changed

+1371/−0 lines, 15 filesdep +MonadPromptdep +arraydep +basesetup-changedbinary-added

Dependencies added: MonadPrompt, array, base, directory, glib, gtk, mtl, random

Files

+ LICENSE view
@@ -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.
+ README view
@@ -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!
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runghc+> import Distribution.Simple (defaultMain)+> main = defaultMain
+ data/icons.png view

binary file changed (absent → 909 bytes)

+ hs-pgms.cabal view
@@ -0,0 +1,32 @@+Name:          hs-pgms+Version:       0.1+Stability:     experimental+Copyright:     (c) 2008 Bertram Felgenhauer+Maintainer:    Bertram Felgenhauer <int-e@gmx.de>+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 <http://www.ccs.neu.edu/home/ramsdell/pgms/index.html>.+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
+ src/GUI.hs view
@@ -0,0 +1,225 @@+-- |+-- Module      : GUI+-- Copyright   : (c) 2008 Bertram Felgenhauer+-- License     : BSD3+--+-- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>+-- 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
+ src/GUI/Common.hs view
@@ -0,0 +1,54 @@+-- |+-- Module      : GUI.Common+-- Copyright   : (c) 2008 Bertram Felgenhauer+-- License     : BSD3+--+-- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>+-- 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+}
+ src/GUI/Config.hs view
@@ -0,0 +1,117 @@+-- |+-- Module      : GUI.Config+-- Copyright   : (c) 2008 Bertram Felgenhauer+-- License     : BSD3+--+-- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>+-- 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)
+ src/GUI/Stats.hs view
@@ -0,0 +1,158 @@+-- |+-- Module      : GUI.Stats+-- Copyright   : (c) 2008 Bertram Felgenhauer+-- License     : BSD3+--+-- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>+-- 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
+ src/Main.hs view
@@ -0,0 +1,238 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2008 Bertram Felgenhauer+-- License     : BSD3+--+-- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>+-- 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
+ src/Mine.hs view
@@ -0,0 +1,301 @@+-- |+-- Module      : Mine+-- Copyright   : (c) 2008 Bertram Felgenhauer+-- License     : BSD3+--+-- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>+-- 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        = "<unknown strategy>",+    sAuthor      = "<unknown author>",+    sDescription = "This strategy has no description.",+    sRun         = \_ -> return "<unimplemented strategy>"+}++-- | 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])+-}
+ src/SimpleStrat.hs view
@@ -0,0 +1,59 @@+-- |+-- Module      : SimpleStrat+-- Copyright   : (c) 2008 Bertram Felgenhauer+-- License     : BSD3+--+-- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>+-- 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 <int-e@gmx.de>",+    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                    = []]
+ src/Strat1.hs view
@@ -0,0 +1,60 @@+-- |+-- Module      : Strat1+-- Copyright   : (c) 2008 Bertram Felgenhauer+-- License     : BSD3+--+-- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>+-- 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 <int-e@gmx.de>",+    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
+ src/Util.hs view
@@ -0,0 +1,53 @@+-- |+-- Module      : Util+-- Copyright   : (c) 2008 Bertram Felgenhauer+-- License     : BSD3+--+-- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>+-- 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)
+ statistics view
@@ -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%)