minesweeper-0.8.8: State/Functions.hs
module State.Functions where
import Configuration
import State
import Core.Square
import Core.Constraints
import Data.Maybe
import Control.Monad
import System.Random
import Data.List
import Data.Function
import qualified Data.ChangeMap as M
import qualified Data.Map as MM
import qualified Data.ChangeSet as S
---------------------------------------------
resetHiddenProbs c gs = gs
{ maxHiddenProb = Nothing
, hiddenProbs = M.empty
, noHiddenProbs = squares (size c) \\ M.keys (revealResults gs)
}
initGameState :: Configuration -> GameState
initGameState c = resetHiddenProbs c $ GameState
{ constraints = initConstraints (size c) (mines c)
, marked = S.empty
, alive = 1
, constraintsProb = 1
, revealResults = M.empty
, maxHiddenProb = undefined
, hiddenProbs = undefined
, noHiddenProbs = undefined
}
initState :: String -> StdGen -> State
initState userName seed = loadState $ State
{ userName = userName
, undoChangesSeed = True
, configuration = c
, seed = seed
, undo = []
, redo = []
, focus = fromJust $ square (size c) 1 1
, mouseFocus = Nothing
, redness = []
, scores = MM.empty
, sortOrder = [SA_Time, SA_Alive, SA_Success]
, timer = Nothing
, revealing = Nothing
, interrupt = Nothing
, hint = Nothing
-- , hinting = Nothing
, game = error "module State.Functions: game was not defined"
}
where
c = configuration' $ Configuration
{ size = board 10 10
, mines = 20
, strategy = Random
, deathProbRange = (1,1)
, allowedDeaths = 0
, recursiveReveal = True
, undoAllowed = False
, hintAllowed = Nothing
-- , numOfSolutions = undefined
}
loadState st = st
{ game = initGameState (configuration st)
}
{-
readState a b s = case reads s of
[(st, s)] | all (==' ') s -> (True, st)
_ -> (False, initState a b)
showState = show . stopState
-}
stopState st = f st { mouseFocus = Nothing }
where
f st
| Just r <- revealing st
= st { revealing = Just $ r { revResult = Nothing }}
| otherwise = st
------------------------------------------ configuration
----------------------- phases
-- the game is finised
isFinished st
= S.size (marked g) + M.size (revealResults g) == msize st
|| alive g == 0
where g = game st
-- winning position (the timer may be stopped)
playerWins st
= isFinished st
&& alive (game st) > 0
-- the game is not yet started (new)
isNew
= null . undo
longInterrupt st
| Just (b, _) <- interrupt st = b
| otherwise = False
-- the table is hidden
hiddenTable st
= longInterrupt st
&& isJust (timer st)
&& not (isFinished st)
-- the focus can be moved
focusMoves st
= not (longInterrupt st)
&& not (isFinished st)
-- the mouse focus is shown
mouseFocusShown st
= focusMoves st
-- && isNothing (busyAnimation_ st)
|| interrupt st == Just (True, OtherApp)
-- reveal / mark / hint can be done
revealCanBeDone st
= markCanBeDone st
&& isNothing (revealing st)
-- mark can be done
markCanBeDone st
= isNothing (interrupt st)
&& not (isFinished st)
-- the timer is active
isActive st
= isNothing (busyAnimation_ st)
&& isNothing (interrupt st)
&& isJust (timer st)
&& not (isFinished st)
-------------- attributes
allSolutions = numOfSolutions . configuration
busyAnimation_ = join . fmap busyAnimation . revealing
revSquare_ = fmap revSquare . revealing
size_ = size . configuration
msize g = xSize s * ySize s where s = size_ g
mines_left st
= mines (configuration st) - S.size (marked $ game st)
information :: State -> Double
information st
| b == 1 = 1
| otherwise = luckFunction a / luckFunction b
where
i = fromIntegral $ allSolutions st
a = fromIntegral (solutions $ constraints $ game st) / i
b = 1 / i
allSquares
= squares . size . configuration
luck :: State -> Double
luck = luckFunction . alive . game
-------------- other
free g p
= not (isRevealed g p) && S.notMember p (marked g)
isRevealed g p
= M.member p (revealResults g)
----------------------------------------
eventPos st m
= maybe (focus st) (calcSquare st) m
calcSquare = restrictSquare . size_
---------------------------------------
showConfiguration c
= unlines $ filter (not . null)
[ unwords [show (xSize s) ++ "×" ++ show (ySize s), "table,", show $ mines c, "mines"]
, showStrategy $ strategy c
, showDPR $ deathProbRange c
]
where
s = size c
showStrategy Random = ""
showStrategy HighestProb = "least information game"
showDPR (0,1) = ""
showDPR (1,1) = "lucky game"
showDPR _ = ""
-- (a, b): ha p valséggel halnánk meg, akkor p>a esetén meghalunk, p<b esetén életben maradunk
{-
, c_allowedDeaths :: Int
, c_recursiveReveal :: Bool
, c_undoAllowed :: Bool
, c_hintAllowed :: Maybe HintType
-}
scoreEntry :: State -> Maybe ScoreEntry
scoreEntry st
| Just t <- timer st
, playerWins st
= Just $ ScoreEntry
{ se_name = userName st
, se_time = t + 1 -- felfelé kerekítünk
, se_alive = alive $ game st
, se_deaths = 0
, se_history = reverse $ map snd $ undo st
}
| otherwise
= Nothing
maxEntries = 10
currentScores :: State -> [ScoreEntry]
currentScores st
= ff $ MM.lookup (configuration st) (scores st)
where
ff (Just l) = l
ff Nothing = []
addScore st
| Just e <- scoreEntry st
, st' <- st { scores = MM.alter (Just . maybe [e] (e:)) (configuration st) (scores st) }
, e `elem` cutScores st'
= Just $ st' { interrupt = Just (False, ViewScore) }
| otherwise
= Nothing
where
cutScores :: State -> [ScoreEntry]
cutScores st
= take maxEntries $ nub $ concat $ transpose [sortByAttr as $ currentScores st | as <- ass]
where
ass = [l2 ++ l1 | i <- [1..length (sortOrder st)], let (l1, l2)= splitAt (i-1) (sortOrder st)]
sortByAttr :: [ScoreAttr] -> [ScoreEntry] -> [ScoreEntry]
sortByAttr as = sortBy (flip compare `on` createRank as)
where
createRank :: [ScoreAttr] -> ScoreEntry -> [Double]
createRank sl e
= [f | x <- sl, (a, f) <- l, a==x]
where
l :: [(ScoreAttr, Double)]
l = [ (SA_Alive, realToFrac (se_alive e))
, (SA_Time, - fromIntegral (se_time e))
, (SA_Success, realToFrac $ successFunction (se_time e) (se_alive e))
]
-----------------------
luckFunction :: Rational -> Double
luckFunction x
= max (- 1/2 * logBase 2 (realToFrac x)) 0
-- megmondja hogy óránként várhatóan hányszor tudnánk teljesíteni egy klasszikus játékot
successFunction :: Int -> Rational -> Rational
successFunction time{-in sec-} alive{-probability-}
= 3600 / fromIntegral time * alive -- 1s 0.5valség
-----------------
forgetChanges x = x
{ marked = S.forget $ marked x
, revealResults = M.forget $ revealResults x
, hiddenProbs = M.forget $ hiddenProbs x
}