minesweeper-0.8.8: Transition/State.hs

module Transition.State
    ( nextState
    ) where

import Configuration
import Event
import State
import State.Functions
import Step
import Core.Square
import Core.Constraints

import Data.Maybe
import Data.List
import Control.Monad (join)
import qualified Data.ChangeMap as M
import qualified Data.Map as MM
import qualified Data.ChangeSet as S

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

type TrState = State -> State



nextState e = dispatchEvent e . fc

fc st = st { game = forgetChanges $ game st }


dispatchEvent :: Event -> State -> Maybe State
dispatchEvent e = case e of
    Init            -> initEvent
    FocusIn m       -> focusIn m
    FocusOut        -> focusOut
    MouseMotion m   -> mouseMotion m
    UpEvent         -> moveFocus_ (0, -1)
    DownEvent       -> moveFocus_ (0, 1)
    LeftEvent       -> moveFocus_ (-1, 0)
    RightEvent      -> moveFocus_ (1, 0)
    HintEvent       -> hintEvent
    FullHintEvent   -> fullHintEvent
    NewEvent        -> newEvent 
    UndoEvent       -> undoEvent
    RedoEvent       -> redoEvent
    MarkEvent m     -> markEvent m
    RevealEvent m   -> revealEvent m
    OpenPreferences -> openPreferences
    PreferencesClosed m -> preferencesClosed m
    ShowScores      -> showScores 
    NewScoreClosed m a -> newScoreClosed m a
    Triggered t     -> dispatchTrigger t
    _               -> error $ "dispatchEvent: " ++ show e

dispatchTrigger t = case t of
    Tick             -> tick
    BusyTick         -> busyTick
    FadeTick         -> fadeTick
    InterruptVisible -> interruptVisible
    RevealDone       -> revealDone 

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

may True x  = Just x
may False _ = Nothing


------------------------------------ Init

initEvent st
    | Just r <- revealing st
    = Just 
        $ st { revealing = Just $ r
                { revResult = Just $ step (configuration st) (revSquare r) (constraints $ game st) (seed st)
                }
             }
    | otherwise
    = Just st

------------------------------------ Ticks

tick st 
    | Just t <- timer st
    = Just 
        $ st { timer = Just $ t+1 }
    | otherwise = Nothing

busyTick st 
    | Just rev <- revealing st
    = Just
        $ st  { revealing = Just $ rev { busyAnimation = Just $ maybe 0 (+1) $ busyAnimation rev }}
    | otherwise = Nothing

fadeTick st 
    = Just 
        $ st { redness = [(s, p') | (s, p) <- redness st, let p' = p-1, p'>0] }

------------------------------------ Focus in/out

focusIn m st 
    | Just (_, OtherApp) <- interrupt st
    = Just
        $ st { interrupt  = Nothing
             , mouseFocus = calcFocus m st 
             }
    | otherwise
    = Just
        $ st { mouseFocus = calcFocus m st 
             }

focusOut st 
    | isNothing $ interrupt st
    = Just 
        $ st { interrupt = Just (False, OtherApp) }
    | otherwise = Nothing

interruptVisible st 
    | Just (False, x) <- interrupt st
    = Just 
        $ st { interrupt = Just (True, x) }
    | otherwise = Nothing

------------------------------------ Mouse and keyboard focus

mouseMotion m st    -- we should always follow the motion of the mouse
    | f <- calcFocus m st
    , f /= mouseFocus st
    = Just 
        $ st { mouseFocus = f }
    | otherwise = Nothing

moveFocus_ d st
    | Just f <- moveFocus d st
    = Just 
        $ st { focus = f }
    | otherwise = Nothing

hintEvent st 
    | revealCanBeDone st
    = Just
        . buildHint
        . stopTimer (isNothing $ hintAllowed $ configuration $ st)
        $ st 
            { hint      = if hint st /= Just NormalHint then Just NormalHint else Nothing
            }         
    | otherwise = Nothing

fullHintEvent st 
    | revealCanBeDone st
    = Just
        . buildHint
        . stopTimer (hintAllowed (configuration $ st) /= Just FullHint)
        $ st 
            { hint      = if hint st /= Just FullHint then Just FullHint else Nothing
            }         
    | otherwise = Nothing

------------------------------------ New

newEvent st 
    | not $ isNew st
    = Just $ new st
    | otherwise = Nothing

------------------------------------ Undo / redo

undoEvent st
    | Nothing <- interrupt st
    , ((g, s): gs) <- undo st
    = Just 
        . stopTimer (not $ undoAllowed $ configuration $ st)
        $ st 
            { undo          = gs
            , redo          = s: redo st
            , game          = g
            , revealing     = Nothing
            }
    | otherwise = Nothing

redoEvent st
    | revealCanBeDone st
    , (s: ss) <- redo st 
    = Just 
        . makeStep s 
        $ st { redo = ss }
    | otherwise = Nothing

------------------------------------ Mark

markEvent m st 
    | markCanBeDone st
    , p <- eventPos st m
    , M.notMember p $ revealResults $ game st
    = Just 
        . mb addScore
        . markEv p 
        . startTimerIfNew
        $ st { redo = takeWhile (compatible p) $ filter (/= Mark p) $ redo st }    
    | otherwise = Nothing
 where
    compatible p (Reveal _ ps) = p `notElem` ps
    compatible _ _ = True

------------------------------------ Reveal

revealEvent m st 
    | revealCanBeDone st
    , p <- eventPos st m
    , (p: ps) <- revTarget p st
    = Just 
        . revEv (recursiveReveal $ configuration st) (p: ps)
        . startTimerIfNew
        . degradeHint
        $ st { redo = [] }
    | otherwise = Nothing


------------------------------------ Preferences

openPreferences st
    | Nothing <- interrupt st
    = Just 
        $ st { interrupt = Just (False, ModifyPreferences) }
    | otherwise = Nothing

preferencesClosed Nothing st
    | Just (_, ModifyPreferences) <- interrupt st
    = Just
        $ st { interrupt = Nothing } 
    | otherwise = Nothing
preferencesClosed (Just c) st
    | Just (_, ModifyPreferences) <- interrupt st
    , c == configuration st
    = Just
        $ st { interrupt = Nothing }
    | Just (_, ModifyPreferences) <- interrupt st
    , size c == size (configuration st)
    , mines c == mines (configuration st)
    = Just
        . stopTimer True
        $ st { interrupt = Nothing
             , configuration = c
             }   
    | Just (_, ModifyPreferences) <- interrupt st
    = Just
        . new
        $ st { interrupt = Nothing
             , configuration = c
             , undo     = []
             , redo     = []
             , focus    = restrictSquare (size c) $ focus st
             }   
    | otherwise = Nothing

------------------------------------ Scores

showScores st
    | Nothing <- interrupt st
    = Just 
        $ st { interrupt = Just (False, ViewScore) }
    | otherwise = Nothing

newScoreClosed (Just n) attr st
    | Just (_, ViewScore) <- interrupt st
    , Just e <- scoreEntry st
    = Just
        $ st 
            { interrupt = Nothing
            , sortOrder = attr
            , userName  = n
            , scores    = MM.adjust (\l -> e { se_name = n }: delete e l) (configuration st) (scores st) 
            } 
newScoreClosed _ attr st
    | Just (_, ViewScore) <- interrupt st
    = Just
        $ st { interrupt = Nothing, sortOrder = attr }
    | otherwise = Nothing



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

mb :: (a -> Maybe a) -> (a -> a)
mb f x = maybe x id (f x)


new st 
    = buildHint
    . loadState
    $ st 
        { undo          = []
        , redo          = reverse (map snd $ undo st) ++ redo st
        , redness       = []
        , timer         = Nothing
        , revealing     = Nothing
        , hint          = Nothing
--        , interrupt     = Nothing -- ???
        }

----------------------------------------------------- Hint

buildHint st
    | isJust (hint st)
    , M.null (hiddenProbs $ game st)
    , isNothing (revealing st){- !!! -}
    = st { game = f (game st) }
    | otherwise
    = st
 where
    f 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 $ allSquares st \\ M.keys (revealResults g)


degradeHint st = st { hint = f $ hint st } where
    f (Just FullHint) = Just FullHint
    f _ = Nothing

------------------------------------------------------------------- Mark

makeStep :: Step -> TrState
makeStep (Reveal seed ps)   = revEv False (reverse ps) . changeSeed seed
makeStep (Mark p)           = markEv p

changeSeed s st = st { seed = s }



markEv :: Square -> TrState
markEv p st 
    | S.member p $ marked g
    = st 
        { game = f g
        , undo = [(f g, s) | (g, s) <- undo st, s /= Mark p] 
        }
    | Just q <- revSquare_ st
    , p == q
    , Just (_, u) <- find' (isReveal . snd) $ undo st
    = st 
        { game = g { marked = S.insert p $ marked g } 
        , undo = (g, Mark p): u
        , revealing = Nothing
        }
    | otherwise
    = st 
        { game = g { marked = S.insert p $ marked g } 
        , undo = (g, Mark p): undo st 
        }
 where
    g = game st
    f g = g { marked = S.delete p $ marked g } 

------------------------------------------------------------------- Reveal

revEv rec ps st 
    = revAction rec ps
    $ st { undo = (game st, Reveal (seed st) []): undo st }


revTarget p st
    | M.notMember p $ revealResults $ game st
    , S.notMember p $ marked $ game st
    = [p]
revTarget p st
    | Just (Just n) <- M.lookup p $ revealResults $ game st
    , ng <- neighbours (size_ st) p
    , n == length [x | x <- ng, S.member x $ marked $ game st ]
    = filter (free $ game st) ng
revTarget _ _ 
    = []

revAction _ [] st 
    = st { revealing = Nothing }
revAction r (x: xs) st 
    = st 
        { revealing = Just $ Revealing 
            { revSquare     = x
            , revResult     = Just $ step (configuration st) x (constraints $ game st) (seed st)
            , recRevealing  = xs
            , busyAnimation = Nothing
            , recursive     = r
            }
        }

revealDone st
    | Just ((ust, Reveal se l), us) <- find' (isReveal . snd) $ undo st
    = Just
    . mb addScore
    . buildHint
    . revAction (recursive rev) (neigh ++ recRevealing rev)
    $ st  { seed        = seed
          , game        = g
          , redness     = [(fo, re) | re/=0] ++ filter ((/=fo) . fst) (redness st) 
          , undo = (ust, Reveal se (fo:l)): us
          }
 where
    Just rev = revealing st

    (Just (RevealResult al mi cs seed)) = revResult rev

    fo = revSquare rev

    re = round $ 100*(1-al)

    g_ = game st
    g = resetHiddenProbs (configuration st) $ g_ 
        { constraints    = cs
        , revealResults  = M.insert fo mi $ revealResults g_
        , alive          = al * alive g_ 
        }

    neigh 
        | Just 0 <- mi
        , recursive rev
        = [p | p<- neighbours (size_ st) fo, free g p, p `notElem` recRevealing rev]
        | otherwise 
        = []


isReveal (Reveal _ _) = True
isReveal _ = False

find' _ [] = Nothing
find' p (x:xs)
    | p x = Just (x, xs)
    | otherwise = case find' p xs of
        Nothing -> Nothing
        Just (y, ys) -> Just (y, x:ys)



---------------------------- timer

startTimerIfNew st
    | isNew st  = st { timer = Just 0 }
    | otherwise = st

stopTimer True st = st { timer = Nothing }
stopTimer _ st = st

----------------------------------------------- focus 

moveFocus (dx, dy) st 
    | focusMoves st
    , (x, y) <- coords $ focus st
    , Just f <- square (size $ configuration st) (x+dx) (y+dy)
    , f /= focus st
    = Just f
    | otherwise
    = Nothing


calcFocus m st 
    = fmap (calcSquare st) m