minesweeper-0.9: Table.hs

module Table 
    ( GameState
    , aliveness
    , appRevResult
    , initGameState
    , isFinished, playerWins
    , msize, mines_left, information
    , luck, luckFunction, free, isMarked, isRevealed, revealResult
    , probability, maxHiddenProb_, gameSeed
    , toggleMark
    , forgetChanges    
    , buildGameHint
    , gameStep
    , allChanges
    ) where

import Configuration
import Core.Square
import Core.SquareConstraints
import Step

import qualified Data.ChangeMap as M
import qualified Data.ChangeSet as S
import Data.SetClass (toList)
import Data.List
import Random
import Data.Data

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

aliveness = alive
gameSeed = currentSeed

allChanges g = S.changes (marked g)
        ++ M.changes (revealResults g)
        ++ M.changes (hiddenProbs g)


data GameState = GameState
    { constraints     :: SquareConstraints
    , marked          :: S.Set Square
    , revealResults   :: M.Map Square (Maybe Int)  -- partially cached (a set of squares would be enough) 
    -- cached
    , constraintsProb :: Probability       -- information
    , maxHiddenProb   :: Maybe Int         -- 0-100
    , hiddenProbs     :: M.Map Square Int    -- 0-100
    , noHiddenProbs   :: [Square]          -- empty squares to be hinted
    -- other info
    , alive           :: Probability
    , currentSeed     :: RandomSeed
    }
        deriving (Show, Typeable, Data)

appRevResult c s rr g = resetHiddenProbs c $ g 
    { constraints    = rrConstraints rr
    , revealResults  = M.insert s (squareState rr) $ revealResults g
    , alive          = safety rr * alive g 
    , currentSeed    = rrSeed rr
    }


resetHiddenProbs c gs = gs
    { maxHiddenProb     = Nothing
    , hiddenProbs       = M.empty
    , noHiddenProbs     = toList (squares (size c)) \\ M.keys (revealResults gs)
    }

initGameState :: Configuration -> RandomSeed -> GameState
initGameState c seed = resetHiddenProbs c $ GameState
    { constraints       = initConstraints (size c) (mines c)
    , marked            = S.empty
    , alive             = 1
    , currentSeed       = seed
    , constraintsProb   = 1
    , revealResults     = M.empty
    , maxHiddenProb     = undefined
    , hiddenProbs       = undefined
    , noHiddenProbs     = undefined
    }


isFinished c g 
    =  S.size (marked g) + M.size (revealResults g) == msize c
    || alive g == 0

-- winning position (the timer may be stopped)
playerWins c g
    =  alive g > 0 && isFinished c g

-----------

msize c = xSize s * ySize s where s = size c

mines_left c g 
    = mines c - S.size (marked g)

information :: Configuration -> GameState -> Double
information c g 
    | all == 1  || s == 1  = 1
    | otherwise = 1 - logBase 2 (fromIntegral s) / logBase 2 (fromIntegral all)
 where
    all = numOfSolutions c
    s = solutions $ constraints g

{-
-- base 2 logarithm for large numbers
log2 :: (Ord a, Num a) => Int -> a -> Double
log2 prec n = f 0 1 1 1 n where

    f :: (Ord a, Num a) => Int -> Int -> a -> a -> a -> Double
    f a b twoa twoam1 nb = case twoa `compare` nb of
        LT              -> f (a+1) b (2*twoa) twoa nb
        GT | b < prec   -> f (2*a-1) (2*b) (twoam1 * twoa) (twoam1 * twoam1) (nb*nb)
        _ -> fromIntegral a / fromIntegral b
-}

--allSquares 
--    = squares . size . configuration

luck :: GameState -> Double
luck = luckFunction . alive

luckFunction :: Rational -> Double
luckFunction x 
    = max (- 1/2 * logBase 2 (realToFrac x)) 0


-------------- other

isMarked p g 
    = S.member p $ marked g

isRevealed g p  
    = M.member p (revealResults g)

revealResult g p  
    = M.lookup p (revealResults g)

free g p 
    = not (isRevealed g p) && not (isMarked p g)

probability p g
    = M.lookup p $ hiddenProbs g

maxHiddenProb_ = maxHiddenProb

forgetChanges x 
    = x { marked          = S.forget $ marked x
        , revealResults   = M.forget $ revealResults x
        , hiddenProbs     = M.forget $ hiddenProbs x
        }

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

toggleMark :: Square -> GameState -> GameState
toggleMark p g
    = g { marked = (if S.member p $ marked g then S.delete else S.insert) p $ marked g } 

buildGameHint c g = g { hiddenProbs = M.fromList l, noHiddenProbs = [], maxHiddenProb = Just (maximum $ map snd l) }
 where
    h p = (p, round $ 100 * clearProb p (constraints g))
    l = map h $ toList (squares $ size c) \\ M.keys (revealResults g)

gameStep x c g
    = step c x (constraints g) (currentSeed g)