module Game
( GState
, size
, board
, Board
, initGState
, deservesUndo
, revealRec
, flag
, info
, isEnd
, isWin
, State (..)
, getP
, mines
, reveal'
-- , diff
) where
import Place
import PlaceSet hiding (size, empty, insert, delete)
import qualified PlaceSet
import Core
import Numeric
import Data.Maybe
import Data.List hiding (delete, insert)
import qualified Data.List as List
import Data.Map hiding (size, singleton, map)
import qualified Data.Map as Map
import System.Random
----------------------------------------
isNotMineAt :: Place -> MMap -> (Rational, MMap)
isNotMineAt p m
= (fromIntegral (solutions' m') / fromIntegral (solutions' m), m')
where
m' = setSum (singleton p) 0 m
degree :: Size -> Place -> MMap -> StdGen -> (Int, MMap, StdGen)
degree s p m r = (x, l !! x, r')
where
ps = listToPlaceSet $ neighbours s p
(x, r') = integerDomino (map solutions' l) r
l = [setSum ps i m | i<-[0..PlaceSet.size ps]]
-----------------------------
data State
= Hidden !Bool (Maybe Rational)
| Death
| Clear Rational !Int -- veszélyesség; szomszédos aknák száma
deriving (Eq, Show)
-----
type Board = Map Place State
get :: Place -> Board -> State
get p b = case Map.lookup p b of
Just s -> s
-- _ -> Hidden
set :: Place -> State -> Board -> Board
set p s b = insert p s b
-----------------------------
data GState = GS
{ field :: MMap
, board_ :: Board
, flagged :: Int
, cleared :: Int
, alive :: Rational
, mines :: Int
, size :: Size
-----------
, revMod :: Maybe Rational
}
deservesUndo g (g':_) | board_ g == board_ g' = 1
deservesUndo g (_:g':_) | board_ g == board_ g' = 2
deservesUndo _ _ = 0
initGState :: Size -> Int -> GState
initGState s mines_ = GS
{ field = setSum (places s) mines_ emptyMMap
, board_ = Map.fromList $ zip (placeSetToList $ places s) $ repeat $ Hidden False Nothing
, flagged = 0
, cleared = 0
, alive = 1
, mines = mines_
, size = s
, revMod = Nothing
}
reveal' :: Bool -> GState -> GState
reveal' all gs
= case revMod gs of
Just 0 | all -> unreveal gs
Just i | i > 0 && not all -> unreveal gs
_ -> revealBoard all gs
unreveal gs | isJust (revMod gs)
= gs { revMod = Nothing, board_ = Map.map f $ board_ gs } where
f (Hidden fl _) = Hidden fl Nothing
f x = x
unreveal gs = gs
revealBoard all gs -- | revMod gs
| solutions' (field gs) == 0 = gs
| otherwise
= gs { board_ = foldr (uncurry Map.insert) (board_ gs) b, revMod = Just $ if all then 0 else mi } where
b = concatMap h $ Map.toList $ board_ gs
mi = maximum $ map (k . snd) b where k (Hidden _ (Just i)) = i
h (p, Hidden fl _) = [(p, Hidden fl $ Just $ fst $ isNotMineAt p (field gs))]
h _ = []
board gs
= case revMod gs of
Just i | i /= 0 -> Map.map (f i) $ board_ gs
_ -> board_ gs
where
f i (Hidden False (Just j)) | j /= 0 && j < i = Hidden False Nothing
f _ x = x
isHidden (Hidden False x) = True
isHidden _ = False
reveal :: Place -> GState -> StdGen -> (GState, StdGen)
reveal p g r
| not $ isHidden (get p (board_ g)) = (g, r)
| pr == 0 = (g { field = f, alive = 0, board_ = insert p Death (board_ g) }, r)
| otherwise = (g { field = f', board_ = insert p (Clear pr d) (board_ g), alive = pr * alive g, cleared = 1 + cleared g }, r')
where
(pr, f) = isNotMineAt p (field g)
(d, f', r')= degree (size g) p f r
flag :: Place -> GState -> ([(Place, State)], GState)
flag p g = case get p $ board_ g of
Hidden True r -> h (Hidden False r) (-1)
Hidden False r | flagged g < mines g -> h (Hidden True r) 1
_ -> ([], g)
where
h x c = ([(p, x)], g { flagged = flagged g + c, board_ = set p x $ board_ g })
getP :: Place -> GState -> State
getP p g = get p (board_ g)
-------------
data Report
= Report Int Int Rational Double
deriving Eq
instance Show Report where
show (Report _ _ 0 _) = "Sorry, you died of necessity."
show (Report 0 0 x y) = "Congratulations! You won with " ++ show_ 2 (luckinessFunction x) ++ " luckyness."
show (Report i _ x y) = "Mines left: " ++ show i ++ " Information: " ++ show_ 1 (100*y) ++ "%" ++ " Luckyness: " ++ show_ 2 (luckinessFunction x)
luckinessFunction :: Rational -> Double
luckinessFunction x = max (- log (realToFrac x) / log 4) 0
show_ :: Int -> Double -> [Char]
show_ i x = showFFloat (Just i) x ""
eval :: GState -> Report
eval g@(GS {size= s@(xS, yS)})
= Report (mines g - flagged g) (xS*yS - cleared g - flagged g) (alive g) y
where
i = solutions' $ setSum (places s) (mines g) emptyMMap
a = fromIntegral (solutions' $ field g) / fromIntegral i
b = 1 / fromIntegral i
y
| b == 1 = 1
| otherwise = luckinessFunction a / luckinessFunction b
isEnd :: GState -> Bool
isEnd g = case eval g of
Report _ _ 0 _ -> True
Report 0 0 _ _ -> True
_ -> False
isWin :: GState -> Bool
isWin g = case eval g of
Report 0 0 _ _ -> True
_ -> False
info :: GState -> String
info = show . eval
-----------------------------
fff ~(x,g,r) = (x, unreveal g,r)
isFlagged (Hidden True _) = True
isFlagged _ = False
revealRec :: Place -> GState -> StdGen -> ([(Place, State)], GState, StdGen)
revealRec p g r = fff $ case getP p g of
Clear _ x | x == sum [1 | q <- neighbours (size g) p, isFlagged (getP q g) ]
-> revRecL (neighbours (size g) p) g r
_ -> revealRecS p g r
revealRecS :: Place -> GState -> StdGen -> ([(Place, State)], GState, StdGen)
revealRecS p g r = case getP p g of
Hidden False _ -> revRec p $ reveal p g r
_ -> ([], g, r)
revRec :: Place -> (GState, StdGen) -> ([(Place, State)], GState, StdGen)
revRec p (g, r) = strictT2 p gp .: case gp of
Clear _ 0 -> revRecL (neighbours (size g) p) g r
_ -> ([], g, r)
where
gp = getP p g
revRecL :: [Place] -> GState -> StdGen -> ([(Place, State)], GState, StdGen)
revRecL [] g r = ([], g, r)
revRecL (p:ps) g r = l .++ revRecL ps g' r' where
~(l, g', r') = revealRecS p g r
strictT2 a b = a `seq` b `seq` (a, b)
p .: ~(ps, g, r) = (p: ps, g, r)
l .++ ~(l', g, r) = (l ++ l', g, r)
----------
-- | Get a value from a discrete distribution with the domino algorithm.
integerDomino :: [Integer] -> StdGen -> (Int, StdGen)
integerDomino [_] r = (0, r)
integerDomino l r = (j, r')
where
(x, r') = randomR (1, sum l) r
j = length $ takeWhile (<x) $ scanl1 (+) l