-- |
-- 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.
--

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])
-}