minesweeper-0.9: State/Functions.hs

{-# LANGUAGE PatternGuards #-}

module State.Functions where

import Configuration
import Preferences
import State
import Core.Square
--import Core.SquareConstraints
import Table

import Data.Maybe
--import Data.SetClass (toList)
import Control.Monad
import 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

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


initState :: String -> RandomSeed -> State
initState userName seed = loadState $ State
    { userName          = userName

    , preferences       = defaultPreferences
    , initialSeed       = seed

    , undo              = []
    , redo              = []

    , focus             = fromJust $ square (size defaultConfiguration) 1 1
    , mouseFocus        = Nothing
    , redness           = []

    , scores            = MM.empty
    , sortOrder         = [SA_Time, SA_Alive, SA_Success]

    , timer             = Nothing
    , revealing         = []
    , interrupt         = Nothing
    , hint              = Nothing
--    , hinting           = Nothing

    , game              = error "module State.Functions: game was not defined"
    }

loadState st = st
    { game = initGameState (configuration $ preferences st) (initialSeed st)
    }

stopState st = st { mouseFocus = Nothing }

revResult st
    | (x:_) <- revealing st
    = cAndG (gameStep $ revSquare x) st

----------------------- phases

-- 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 (cAndG isFinished st)

cAndG f st = f (configuration $ preferences st) (game st)

-- the focus can be moved
focusMoves st
    =  not (longInterrupt st)
    && not (cAndG 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
    =  isNothing (interrupt st)
    && not (cAndG isFinished st)
    && null (revealing st) 

-- mark can be done
markCanBeDone st
    =  isNothing (interrupt st)
    && cAndG mines_left st > 0
    && not (cAndG isFinished st)

-- the timer is active
isActive st 
    =  isNothing (busyAnimation_ st) 
    && isNothing (interrupt st) 
    && isJust (timer st)
    && not (cAndG isFinished st)


-------------- attributes

-- seed = currentSeed . game

-- allSolutions = numOfSolutions . configuration

busyAnimation_ = join . fmap busyAnimation . l2m . revealing

l2m (x:_) = Just x
l2m [] = Nothing

size_ = size . configuration . preferences
{-
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 
    | all == 1  || s == 1  = 1
    | otherwise = 1 - logBase 2 (fromIntegral s) / logBase 2 (fromIntegral all)
 where
    all = allSolutions st
    s = solutions $ constraints $ game st


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


luck :: State -> Double
luck = luckFunction . alive . game

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


-------------- 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
    , cAndG playerWins st
    = Just $ ScoreEntry 
        { se_name    = userName st
        , se_time    = t + 1
        , se_alive   = aliveness $ game st
        , se_deaths  = 0
        , se_history = map (fmap (const ())) $ reverse $ undo st
        }
    | otherwise
    = Nothing


maxEntries = 10

currentScores :: State -> [ScoreEntry]
currentScores st 
    = ff $ MM.lookup (preferences 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:)) (preferences 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))
            ]



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

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