module Gamgine.State.StateTreeZipper where
import qualified Data.List as L
import Data.List ((!!))
import qualified Gamgine.State.State as S
import qualified Gamgine.State.StateTree as ST
import Gamgine.State.StateTree (root, enterWhen, leaveWhen, adjacents, StateTree(..), StateTransition(..))
import qualified Gamgine.State.KeyInfo as KI
import qualified Gamgine.State.MouseInfo as MI
import qualified Gamgine.State.InputInfo as II

-- | a zipper for the state tree
data Zipper a = Zipper {
   forall a. Zipper a -> [Step a]
path    :: [Step a],
   forall a. Zipper a -> StateTree a
current :: ST.StateTree a
   }


-- | represents a step walking the state tree
data Step a = Step {
   forall a. Step a -> (State a, EnterWhen, EnterWhen)
parent   :: (S.State a, ST.EnterWhen, ST.LeaveWhen),
   -- (beforeSiblings, afterSiblings)
   forall a. Step a -> ([StateTree a], [StateTree a])
siblings :: ([ST.StateTree a], [ST.StateTree a])
   }


-- | create a zipper from a StateTree
zipper :: ST.StateTree a -> Zipper a
zipper :: forall a. StateTree a -> Zipper a
zipper StateTree a
s = [Step a] -> StateTree a -> Zipper a
forall a. [Step a] -> StateTree a -> Zipper a
Zipper [] StateTree a
s


-- | checks if a state transition should occur, otherwise
--   calls the keyEvent function of the current state
handleKeyEvent :: KI.KeyInfo -> a -> Zipper a -> (a, Zipper a)
handleKeyEvent :: forall a. KeyInfo -> a -> Zipper a -> (a, Zipper a)
handleKeyEvent KeyInfo
ki a
a z :: Zipper a
z@(Zipper [Step a]
ps StateTree a
c)
   | KeyInfo -> EnterWhen -> Bool
transitionAppliesKI KeyInfo
ki (StateTree a -> EnterWhen
forall a. StateTree a -> EnterWhen
ST.leaveWhen (StateTree a -> EnterWhen)
-> (Zipper a -> StateTree a) -> Zipper a -> EnterWhen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipper a -> StateTree a
forall a. Zipper a -> StateTree a
current (Zipper a -> EnterWhen) -> Zipper a -> EnterWhen
forall a b. (a -> b) -> a -> b
$ Zipper a
z) = MousePos -> a -> Zipper a -> (a, Zipper a)
forall a. MousePos -> a -> Zipper a -> (a, Zipper a)
goUp MousePos
mp a
a Zipper a
z
   | Bool
otherwise = 
      case (Bool -> Bool) -> [Bool] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True) ([Bool] -> Maybe Int) -> [Bool] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (StateTree a -> Bool) -> [StateTree a] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
L.map (KeyInfo -> EnterWhen -> Bool
transitionAppliesKI KeyInfo
ki (EnterWhen -> Bool)
-> (StateTree a -> EnterWhen) -> StateTree a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateTree a -> EnterWhen
forall a. StateTree a -> EnterWhen
ST.enterWhen) (StateTree a -> [StateTree a]
forall a. StateTree a -> [StateTree a]
ST.adjacents (StateTree a -> [StateTree a])
-> (Zipper a -> StateTree a) -> Zipper a -> [StateTree a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipper a -> StateTree a
forall a. Zipper a -> StateTree a
current (Zipper a -> [StateTree a]) -> Zipper a -> [StateTree a]
forall a b. (a -> b) -> a -> b
$ Zipper a
z) of
           Just Int
idx -> Int -> MousePos -> a -> Zipper a -> (a, Zipper a)
forall a. Int -> MousePos -> a -> Zipper a -> (a, Zipper a)
goDown Int
idx MousePos
mp a
a Zipper a
z
           Maybe Int
_        -> let (a
a', StateTree a
c') = KeyInfo -> a -> StateTree a -> (a, StateTree a)
forall a. KeyInfo -> a -> StateTree a -> (a, StateTree a)
ST.handleKeyEvent KeyInfo
ki a
a StateTree a
c in (a
a', [Step a] -> StateTree a -> Zipper a
forall a. [Step a] -> StateTree a -> Zipper a
Zipper [Step a]
ps StateTree a
c') 
   where
      mp :: MousePos
mp = KeyInfo -> MousePos
KI.mousePos KeyInfo
ki


-- | checks if a state transition should occur, otherwise
--   calls the mouseEvent function of the current state
handleMouseEvent :: MI.MouseInfo -> a -> Zipper a -> (a, Zipper a)
handleMouseEvent :: forall a. MouseInfo -> a -> Zipper a -> (a, Zipper a)
handleMouseEvent MouseInfo
mi a
a z :: Zipper a
z@(Zipper [Step a]
ps StateTree a
c)
   | MouseInfo -> EnterWhen -> Bool
transitionAppliesMI MouseInfo
mi (StateTree a -> EnterWhen
forall a. StateTree a -> EnterWhen
ST.leaveWhen (StateTree a -> EnterWhen)
-> (Zipper a -> StateTree a) -> Zipper a -> EnterWhen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipper a -> StateTree a
forall a. Zipper a -> StateTree a
current (Zipper a -> EnterWhen) -> Zipper a -> EnterWhen
forall a b. (a -> b) -> a -> b
$ Zipper a
z) = MousePos -> a -> Zipper a -> (a, Zipper a)
forall a. MousePos -> a -> Zipper a -> (a, Zipper a)
goUp MousePos
mp a
a Zipper a
z
   | Bool
otherwise = 
      case (Bool -> Bool) -> [Bool] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True) ([Bool] -> Maybe Int) -> [Bool] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (StateTree a -> Bool) -> [StateTree a] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
L.map (MouseInfo -> EnterWhen -> Bool
transitionAppliesMI MouseInfo
mi (EnterWhen -> Bool)
-> (StateTree a -> EnterWhen) -> StateTree a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateTree a -> EnterWhen
forall a. StateTree a -> EnterWhen
ST.enterWhen) (StateTree a -> [StateTree a]
forall a. StateTree a -> [StateTree a]
ST.adjacents (StateTree a -> [StateTree a])
-> (Zipper a -> StateTree a) -> Zipper a -> [StateTree a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipper a -> StateTree a
forall a. Zipper a -> StateTree a
current (Zipper a -> [StateTree a]) -> Zipper a -> [StateTree a]
forall a b. (a -> b) -> a -> b
$ Zipper a
z) of
           Just Int
idx -> Int -> MousePos -> a -> Zipper a -> (a, Zipper a)
forall a. Int -> MousePos -> a -> Zipper a -> (a, Zipper a)
goDown Int
idx MousePos
mp a
a Zipper a
z
           Maybe Int
_        -> let (a
a', StateTree a
c') = MouseInfo -> a -> StateTree a -> (a, StateTree a)
forall a. MouseInfo -> a -> StateTree a -> (a, StateTree a)
ST.handleMouseEvent MouseInfo
mi a
a StateTree a
c in (a
a', [Step a] -> StateTree a -> Zipper a
forall a. [Step a] -> StateTree a -> Zipper a
Zipper [Step a]
ps StateTree a
c') 
   where
      mp :: MousePos
mp = MouseInfo -> MousePos
MI.mousePos MouseInfo
mi
      
   
-- | leave the current state and enter the parent state
goUp :: II.MousePos -> a -> Zipper a -> (a, Zipper a)
goUp :: forall a. MousePos -> a -> Zipper a -> (a, Zipper a)
goUp MousePos
mp a
a z :: Zipper a
z@(Zipper [] StateTree a
_) = (a
a, Zipper a
z)
goUp MousePos
mp a
a z :: Zipper a
z@(Zipper (Step (State a
p,EnterWhen
e,EnterWhen
l) ([StateTree a]
beforeSibs, [StateTree a]
afterSibs):[Step a]
ps) StateTree a
c) =
   case (State a -> MousePos -> a -> Maybe (a, State a)
forall a. State a -> MousePos -> a -> Maybe (a, State a)
S.enter State a
p) MousePos
mp a
a' of
        Just (a
a'', State a
p') -> (a
a'', [Step a] -> StateTree a -> Zipper a
forall a. [Step a] -> StateTree a -> Zipper a
Zipper [Step a]
ps (StateTree a -> Zipper a) -> StateTree a -> Zipper a
forall a b. (a -> b) -> a -> b
$ State a -> EnterWhen -> EnterWhen -> [StateTree a] -> StateTree a
forall a.
State a -> EnterWhen -> EnterWhen -> [StateTree a] -> StateTree a
ST.Branch State a
p' EnterWhen
e EnterWhen
l ([StateTree a]
beforeSibs [StateTree a] -> [StateTree a] -> [StateTree a]
forall a. [a] -> [a] -> [a]
++ (StateTree a
c' StateTree a -> [StateTree a] -> [StateTree a]
forall a. a -> [a] -> [a]
: [StateTree a]
afterSibs)))
        Maybe (a, State a)
_              -> (a
a, Zipper a
z)
   where
      (a
a' , StateTree a
c') = a -> StateTree a -> (a, StateTree a)
forall a. a -> StateTree a -> (a, StateTree a)
ST.leaveState a
a StateTree a
c


-- | leave the current state and enter the adjacent state
--   with index 'adjIdx'
goDown :: Int -> II.MousePos -> a -> Zipper a -> (a, Zipper a)
goDown :: forall a. Int -> MousePos -> a -> Zipper a -> (a, Zipper a)
goDown Int
adjIdx MousePos
mp a
a z :: Zipper a
z@(Zipper [Step a]
ps (Branch State a
c EnterWhen
e EnterWhen
l [StateTree a]
as))
   | Int
adjIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [StateTree a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [StateTree a]
as = (a
a, Zipper a
z)
   | Bool
otherwise =
      case MousePos -> a -> StateTree a -> Maybe (a, StateTree a)
forall a. MousePos -> a -> StateTree a -> Maybe (a, StateTree a)
ST.enterState MousePos
mp a
a' StateTree a
s of
           Just (a
a'', StateTree a
s') -> (a
a'', [Step a] -> StateTree a -> Zipper a
forall a. [Step a] -> StateTree a -> Zipper a
Zipper (((State a, EnterWhen, EnterWhen)
-> ([StateTree a], [StateTree a]) -> Step a
forall a.
(State a, EnterWhen, EnterWhen)
-> ([StateTree a], [StateTree a]) -> Step a
Step (State a
c',EnterWhen
e,EnterWhen
l) ([StateTree a]
beforeSibs, [StateTree a]
afterSibs))Step a -> [Step a] -> [Step a]
forall a. a -> [a] -> [a]
:[Step a]
ps) StateTree a
s')
           Maybe (a, StateTree a)
_              -> (a
a, Zipper a
z)
   where
      (a
a', State a
c')   = (State a -> a -> (a, State a)
forall a. State a -> a -> (a, State a)
S.leave State a
c) a
a
      s :: StateTree a
s          = [StateTree a]
as [StateTree a] -> Int -> StateTree a
forall a. HasCallStack => [a] -> Int -> a
!! Int
adjIdx
      beforeSibs :: [StateTree a]
beforeSibs = Int -> [StateTree a] -> [StateTree a]
forall a. Int -> [a] -> [a]
L.take Int
adjIdx [StateTree a]
as
      afterSibs :: [StateTree a]
afterSibs  = Int -> [StateTree a] -> [StateTree a]
forall a. Int -> [a] -> [a]
L.drop (Int
adjIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [StateTree a]
as


-- | replace the current state
replace :: S.State a -> Zipper a -> Zipper a
replace :: forall a. State a -> Zipper a -> Zipper a
replace State a
s (Zipper [Step a]
p (ST.Branch State a
_ EnterWhen
e EnterWhen
l [StateTree a]
ss)) = [Step a] -> StateTree a -> Zipper a
forall a. [Step a] -> StateTree a -> Zipper a
Zipper [Step a]
p (State a -> EnterWhen -> EnterWhen -> [StateTree a] -> StateTree a
forall a.
State a -> EnterWhen -> EnterWhen -> [StateTree a] -> StateTree a
ST.Branch State a
s EnterWhen
e EnterWhen
l [StateTree a]
ss)


-- | checks if the KeyInfo matches the StateTransition
transitionAppliesKI :: KI.KeyInfo -> StateTransition -> Bool
transitionAppliesKI :: KeyInfo -> EnterWhen -> Bool
transitionAppliesKI KeyInfo
ki (ByKey Key
key InputState
status) =
   KeyInfo -> Key
KI.key KeyInfo
ki Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
key Bool -> Bool -> Bool
&& KeyInfo -> InputState
KI.status KeyInfo
ki InputState -> InputState -> Bool
forall a. Eq a => a -> a -> Bool
== InputState
status

transitionAppliesKI KeyInfo
ki (ByKeyWithMod Key
key InputState
status Modifier
mod) =
   KeyInfo -> Key
KI.key KeyInfo
ki Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
key Bool -> Bool -> Bool
&& KeyInfo -> InputState
KI.status KeyInfo
ki InputState -> InputState -> Bool
forall a. Eq a => a -> a -> Bool
== InputState
status Bool -> Bool -> Bool
&& Modifier -> ModifierKeys -> Bool
II.isModifierPressed Modifier
mod (KeyInfo -> ModifierKeys
KI.modifiers KeyInfo
ki)

transitionAppliesKI KeyInfo
_ EnterWhen
_ = Bool
False


-- | checks of the MouseInfo matches the StateTransition
transitionAppliesMI :: MI.MouseInfo -> StateTransition -> Bool
transitionAppliesMI :: MouseInfo -> EnterWhen -> Bool
transitionAppliesMI MouseInfo
mi (ByMouse MouseButton
button InputState
status) =
   MouseInfo -> MouseButton
MI.button MouseInfo
mi MouseButton -> MouseButton -> Bool
forall a. Eq a => a -> a -> Bool
== MouseButton
button Bool -> Bool -> Bool
&& MouseInfo -> InputState
MI.status MouseInfo
mi InputState -> InputState -> Bool
forall a. Eq a => a -> a -> Bool
== InputState
status

transitionAppliesMI MouseInfo
mi (ByMouseWithMod MouseButton
button InputState
status Modifier
mod) =
   MouseInfo -> MouseButton
MI.button MouseInfo
mi MouseButton -> MouseButton -> Bool
forall a. Eq a => a -> a -> Bool
== MouseButton
button Bool -> Bool -> Bool
&& MouseInfo -> InputState
MI.status MouseInfo
mi InputState -> InputState -> Bool
forall a. Eq a => a -> a -> Bool
== InputState
status Bool -> Bool -> Bool
&& Modifier -> ModifierKeys -> Bool
II.isModifierPressed Modifier
mod (MouseInfo -> ModifierKeys
MI.modifiers MouseInfo
mi)

transitionAppliesMI MouseInfo
_ EnterWhen
_ = Bool
False