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