minesweeper-0.8.8: Step.hs

module Step
    ( step
    , RevealResult (..)
    ) where

-------------------------------------------

import Configuration
import Core.Square
import Core.Constraints

import Data.Ratio
import Data.List
import Data.Maybe
import System.Random
import Data.Binary


-------------------------------------------

data RevealResult = RevealResult
    { safety        :: !Probability
    , squareState   :: !(Maybe Int)
    , rrConstraints :: !Constraints
    , rrSeed        :: !StdGen
    }
        deriving (Show)

instance Binary RevealResult where
    put = error "put on RevealResult"
    get = error "get on RevealResult"

-------------------------------------------



step :: Configuration -> Square -> Constraints -> StdGen -> RevealResult
step conf p cs r 
    | dead = RevealResult prob Nothing (setSum [p] 1 cs) r_
    | otherwise = x `seq` RevealResult prob (Just x) (l !! x) r'
 where
    cs' = setSum [p] 0 cs

    l = distribution (neighbours (size conf) p) cs'

    (dead, r_) = appDeath (deathProbRange conf) (1-prob) r
    (x, r') = appStrat (strategy conf) (map solutions l) r_

    prob = fromIntegral (solutions cs') / fromIntegral (solutions cs)


appDeath _ 0 r = (False, r)
appDeath _ 1 r = (True, r)
appDeath (a, _) p r | p <= a = (False, r)
appDeath (_, b) p r | p >= b = (True, r)
appDeath (a, b) p r = (i==0, r') where 
    (i, r') = integerDomino [c, d] r
    (c, d) = ff (p - a, b - p)

    ff (x, y) = (numerator (d*x), numerator (d*y))  where d = fromInteger $ denominator (x*y)


appStrat Random l r 
    = integerDomino l r
appStrat HighestProb l r 
    = (fromJust $ findIndex (==y) l, r) where
        y = maximum l


----------------------

-- | Get a value from a discrete distribution with the domino algorithm.
integerDomino :: [Integer] -> StdGen -> (Int, StdGen)
integerDomino (0: is) r = (x + 1, r') where (x, r') = integerDomino is r
integerDomino l@(i: _) r 
    | i == sl   = (0, r)
    | otherwise = (j, r')
 where
    sl = sum l
    (x, r') = randomR (1, sl) r

    j = length $ takeWhile (<x) $ scanl1 (+) l