minesweeper-0.9: Transition/State.hs
{-# LANGUAGE PatternGuards #-}
module Transition.State
( nextState
) where
import Configuration
import Preferences
import Table
import Event
import State
import State.Functions
import Step
import Core.Square
import Data.Maybe
import Data.SetClass (toList)
import Data.List
import qualified Data.Map as MM
---------------------------------------------------
type TrState = State -> State
nextState e = dispatchEvent e . fc
fc st = st { game = forgetChanges $ game st }
dispatchEvent :: Event -> State -> State
dispatchEvent e st = ($ st) $ case e of
MouseMotion m -> moveMouseFocus m
UpEvent | focusMoves st -> moveFocus (0, -1)
DownEvent | focusMoves st -> moveFocus (0, 1)
LeftEvent | focusMoves st -> moveFocus (-1, 0)
RightEvent | focusMoves st -> moveFocus (1, 0)
HintEvent | revealCanBeDone st -> hintEvent
FullHintEvent | revealCanBeDone st -> fullHintEvent
NewEvent -> newGame
UndoEvent | noInterrupt st && not (null $ undo st) -> undoEvent
RedoEvent | revealCanBeDone st && not (null $ redo st) -> redoEvent
MarkEvent m | markCanBeDone st -> markEvent m
RevealEvent m | revealCanBeDone st -> revealEvent m
FocusOut | noInterrupt st -> setInterrupt OtherApp
OpenPreferences | noInterrupt st -> setInterrupt ModifyPreferences
ShowScores | noInterrupt st -> setInterrupt ViewScore
FocusIn m | noInterrupt st -> moveMouseFocus m
FocusIn m | checkInterrupt OtherApp st -> clearInterrupt . moveMouseFocus m
PreferencesClosed m | checkInterrupt ModifyPreferences st -> clearInterrupt . preferencesClosed m
NewScoreClosed m a | checkInterrupt ViewScore st -> clearInterrupt . newScoreClosed m a
Triggered t -> dispatchTrigger t
_ -> id
dispatchTrigger t = case t of
Tick -> tick
BusyTick -> busyTick
FadeTick -> fadeTick
InterruptVisible -> interruptVisible
RevealDone res -> revealDone res
------------------------------------ Ticks
tick st
= st { timer = fmap (+1) $ timer st }
busyTick st
= st { revealing = mapHead f $ revealing st } where
f rev = rev { busyAnimation = Just $ maybe 0 (+1) $ busyAnimation rev }
fadeTick st
= st { redness = [(s, p') | (s, p) <- redness st, let p' = p-1, p'>0] }
mapHead f (x:xs) = f x: xs
mapHead _ [] = []
------------------------------------
interruptVisible st
= st { interrupt = fmap (\(False, x) -> (True, x)) $ interrupt st }
------------------------------------ Mouse and keyboard focus
moveMouseFocus m st
= st { mouseFocus = fmap (calcSquare st) m }
moveFocus (dx, dy) st
= st { focus = maybe (focus st) id $ square (size $ configuration $ preferences st) (x+dx) (y+dy) }
where
(x, y) = coords $ focus st
-----------------------------------------
hintEvent st
= buildHint
. stopTimerIf (isNothing $ hintAllowed $ preferences st)
$ st { hint = if hint st /= Just NormalHint then Just NormalHint else Nothing
}
fullHintEvent st
= buildHint
. stopTimerIf (hintAllowed (preferences st) /= Just FullHint)
$ st { hint = if hint st /= Just FullHint then Just FullHint else Nothing
}
------------------------------------ Undo / redo
undoEvent st
= stopTimerIf (not $ undoAllowed $ preferences $ st)
. makeUndo
. stopRevealing
$ st
stopRevealing st = st { revealing = [] }
makeUndo st
| (Mark s: ss) <- undo st
= st { undo = ss
, redo = Mark s: redo st
, game = toggleMark s (game st)
}
| otherwise
= st { undo = u
, redo = r
, game = g
}
where
(r, u, g) = undoEvents (redo st) (undo st) (game $ loadState st)
undoEvents r [] g = (r, [], g)
undoEvents r (Reveal s: es) g = undoEvents (Reveal s: r) es g
undoEvents r (Mark s: es) g = undoEvents (Mark s: r) es g
undoEvents r (CachedState g: es) _ = (CachedState (): r, es, g)
redoEvent st
| (Mark s: ss) <- redo st
= markEv s
$ st { redo = ss }
| (CachedState _: ss) <- redo st
, (x, y) <- span isReveal ss
= revEv False [s | Reveal s <- x]
$ st { redo = y }
| ss <- redo st
, (x, y) <- span isReveal ss
= revEv False [s | Reveal s <- x]
$ st { redo = y }
------------------------------------ Mark
markEvent m st
| p <- eventPos st m
, not (isRevealed (game st) p)
= mb addScore
. markEv p
. startTimerIfNew
$ st { redo = takeWhile (compatible p) $ filter (/= Mark p) $ redo st }
| otherwise = st
where
compatible p (Reveal q) = p /= q
compatible _ _ = True
------------------------------------ Reveal
revealEvent m st
| p <- eventPos st m
, (p: ps) <- revTarget p st
= revEv (recursiveReveal $ preferences st) (p: ps)
. startTimerIfNew
. degradeHint
$ st { redo = [] }
| otherwise = st
revTarget p st
| free (game st) p
= [p]
| Just (Just n) <- revealResult (game st) p
, ng <- toList $ neighbours (size_ st) p
, n == length [x | x <- ng, isMarked x $ game st ]
= ng
| otherwise
= []
---------------------------
setInterrupt i st = st { interrupt = Just (False, i) }
clearInterrupt st = st { interrupt = Nothing }
noInterrupt = isNothing . interrupt
checkInterrupt i st
| Just (_, j) <- interrupt st
= i == j
checkInterrupt _ _
= False
------------------------------------ Preferences
preferencesClosed Nothing st = st
preferencesClosed (Just c) st
| c == preferences st
= st
| {- tableConfig ( -} configuration c == configuration (preferences st)
= stopTimerIf True
$ st { preferences = c
}
| otherwise
= newGame
$ st { preferences = c
-- , undo = []
-- , redo = []
, focus = restrictSquare (size $ configuration c) $ focus st
}
------------------------------------ Scores
newScoreClosed (Just n) attr st
| Just e <- scoreEntry st
= st
{ sortOrder = attr
, userName = n
, scores = MM.adjust (\l -> e { se_name = n }: delete e l) (preferences st) (scores st)
}
newScoreClosed Nothing attr st
= st { sortOrder = attr }
-------------------------------------------------------------------
mb :: (a -> Maybe a) -> (a -> a)
mb f x = maybe x id (f x)
newGame st
= buildHint
. loadState
. stopRevealing
$ st
{ undo = []
, redo = [] -- reverse (map (fmap (const ())) $ undo st) ++ redo st
, redness = []
, timer = Nothing
, hint = Nothing
, initialSeed = gameSeed (game st)
}
----------------------------------------------------- Hint
buildHint st
| isJust (hint st)
-- , M.null (hiddenProbs $ game st)
, null (revealing st){- !!! -}
= st { game = cAndG buildGameHint st }
| otherwise
= st
degradeHint st = st { hint = f $ hint st } where
f (Just FullHint) = Just FullHint
f _ = Nothing
------------------------------------------------------------------- Mark
notMark p (Mark q) = p /= q
notMark _ _ = True
markEv :: Square -> TrState
markEv p st = appGame (toggleMark p) $ mm p st
appGame f st = st { game = f (game st) }
mm p st
| isMarked p g
= st
{ undo = map (fmap $ toggleMark p) ua ++ ub
}
| (q:_) <- revealing st
, p == revSquare q
, Just (_, u) <- find' isReveal $ undo st
= stopRevealing st
{ undo = Mark p: u
}
| otherwise
= st
{ undo = Mark p: undo st
}
where
(ua, _: ub) = span (notMark p) (undo st)
g = game st
------------------------------------------------------------------- Reveal
revEv rec ps st
= revAction rec ps
$ st { undo = CachedState (game st): undo st }
revAction r xs st
= st
{ revealing = dropWhile (not . free (game st) . revSquare)
$ map buildRev xs ++ revealing st
}
where
buildRev x = Revealing
{ revSquare = x
, busyAnimation = Nothing
, recursive = r
}
revealDone rr st
= mb addScore
. buildHint
. revAction (recursive rev) neigh
$ st { game = appRevResult (configuration $ preferences st) fo rr (game st)
, redness = [(fo, re) | re/= 0] ++ filter ((/=fo) . fst) (redness st)
, undo = Reveal fo: undo st
, revealing = revs
}
where
(rev: revs) = revealing st
fo = revSquare rev
re = round $ 100 * (1 - safety rr) :: Int
neigh
| recursive rev
, Just 0 <- squareState rr
= toList $ neighbours (size_ st) fo
| 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
stopTimerIf True st = st { timer = Nothing }
stopTimerIf False st = st