module Data.Component.MessageLayer where

import Control.Lens
import Control.Lens.TH.Rules
import Control.Monad.State
import Data.Aeson
import Data.Typeable (Typeable)
import Linear
import MiniLight
import qualified Data.Component.Basic as Basic
import qualified Data.Component.Layer as CLayer
import qualified Data.Component.AnimationLayer as CAnim
import qualified Data.Component.MessageEngine as CME
import qualified SDL.Vect as Vect

data Config = Config {
  Config -> Config
basic :: Basic.Config,
  Config -> Config
engine :: CME.Config,
  Config -> Config
window :: CLayer.Config,
  Config -> Config
next :: CAnim.Config
}

instance FromJSON Config where
  parseJSON :: Value -> Parser Config
parseJSON = String -> (Object -> Parser Config) -> Value -> Parser Config
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "config" ((Object -> Parser Config) -> Value -> Parser Config)
-> (Object -> Parser Config) -> Value -> Parser Config
forall a b. (a -> b) -> a -> b
$ \v :: Object
v -> do
    Config
layerConf <- Value -> Parser Config
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser Config) -> Parser Value -> Parser Config
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: "window"
    Config
nextConf <- Value -> Parser Config
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser Config) -> Parser Value -> Parser Config
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: "next"
    Config
messageEngineConf <- Value -> Parser Config
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser Config) -> Parser Value -> Parser Config
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: "engine"

    Config -> Parser Config
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> Parser Config) -> Config -> Parser Config
forall a b. (a -> b) -> a -> b
$ Config -> Config -> Config -> Config -> Config
Config (Config
layerConf Config -> Getting Config Config Config -> Config
forall s a. s -> Getting a s a -> a
^. Getting Config Config Config
forall c. HasConfig c => Lens' c Config
Basic.config) Config
messageEngineConf Config
layerConf Config
nextConf

data MessageLayer = MessageLayer {
  MessageLayer -> MessageEngine
messageEngine :: CME.MessageEngine,
  MessageLayer -> Layer
layer :: CLayer.Layer,
  MessageLayer -> AnimationLayer
cursor :: CAnim.AnimationLayer,
  MessageLayer -> Config
config :: Config
}

makeLensesWith lensRules_ ''Config
makeLensesWith lensRules_ ''MessageLayer

instance Basic.HasConfig Config where
  config :: (Config -> f Config) -> Config -> f Config
config = (Config -> f Config) -> Config -> f Config
Lens' Config Config
_basic

engineL :: Lens' MessageLayer CME.MessageEngine
engineL :: (MessageEngine -> f MessageEngine)
-> MessageLayer -> f MessageLayer
engineL = (MessageLayer -> MessageEngine)
-> (MessageLayer -> MessageEngine -> MessageLayer)
-> Lens MessageLayer MessageLayer MessageEngine MessageEngine
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens MessageLayer -> MessageEngine
messageEngine (\s :: MessageLayer
s a :: MessageEngine
a -> MessageLayer
s { messageEngine :: MessageEngine
messageEngine = MessageEngine
a })

cursorL :: Lens' MessageLayer CAnim.AnimationLayer
cursorL :: (AnimationLayer -> f AnimationLayer)
-> MessageLayer -> f MessageLayer
cursorL = (MessageLayer -> AnimationLayer)
-> (MessageLayer -> AnimationLayer -> MessageLayer)
-> Lens MessageLayer MessageLayer AnimationLayer AnimationLayer
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens MessageLayer -> AnimationLayer
cursor (\s :: MessageLayer
s a :: AnimationLayer
a -> MessageLayer
s { cursor :: AnimationLayer
cursor = AnimationLayer
a })

data MessageLayerEvent where
  Finish :: MessageLayerEvent
  deriving Typeable

instance EventType MessageLayerEvent where
  getEventType :: MessageLayerEvent -> Text
getEventType Finish = "finish"

instance ComponentUnit MessageLayer where
  update :: MessageLayer -> LightT env m MessageLayer
update = StateT MessageLayer (LightT env m) ()
-> MessageLayer -> LightT env m MessageLayer
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT MessageLayer (LightT env m) ()
 -> MessageLayer -> LightT env m MessageLayer)
-> StateT MessageLayer (LightT env m) ()
-> MessageLayer
-> LightT env m MessageLayer
forall a b. (a -> b) -> a -> b
$ do
    LensLike'
  (Zoomed (StateT MessageEngine (LightT env m)) ())
  MessageLayer
  MessageEngine
-> StateT MessageEngine (LightT env m) ()
-> StateT MessageLayer (LightT env m) ()
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (StateT MessageEngine (LightT env m)) ())
  MessageLayer
  MessageEngine
Lens MessageLayer MessageLayer MessageEngine MessageEngine
engineL (StateT MessageEngine (LightT env m) ()
 -> StateT MessageLayer (LightT env m) ())
-> StateT MessageEngine (LightT env m) ()
-> StateT MessageLayer (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ do
      MessageEngine
c <- Getting MessageEngine MessageEngine MessageEngine
-> StateT MessageEngine (LightT env m) MessageEngine
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting MessageEngine MessageEngine MessageEngine
forall a. a -> a
id
      (MessageEngine -> Identity MessageEngine)
-> MessageEngine -> Identity MessageEngine
forall a. a -> a
id ((MessageEngine -> Identity MessageEngine)
 -> MessageEngine -> Identity MessageEngine)
-> StateT MessageEngine (LightT env m) MessageEngine
-> StateT MessageEngine (LightT env m) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> m b -> m ()
<~ LightT env m MessageEngine
-> StateT MessageEngine (LightT env m) MessageEngine
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MessageEngine -> LightT env m MessageEngine
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, HasLoopEnv env,
 HasComponentEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m c
update MessageEngine
c)

    LensLike'
  (Zoomed (StateT AnimationLayer (LightT env m)) ())
  MessageLayer
  AnimationLayer
-> StateT AnimationLayer (LightT env m) ()
-> StateT MessageLayer (LightT env m) ()
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (StateT AnimationLayer (LightT env m)) ())
  MessageLayer
  AnimationLayer
Lens MessageLayer MessageLayer AnimationLayer AnimationLayer
cursorL (StateT AnimationLayer (LightT env m) ()
 -> StateT MessageLayer (LightT env m) ())
-> StateT AnimationLayer (LightT env m) ()
-> StateT MessageLayer (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ do
      AnimationLayer
c <- Getting AnimationLayer AnimationLayer AnimationLayer
-> StateT AnimationLayer (LightT env m) AnimationLayer
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting AnimationLayer AnimationLayer AnimationLayer
forall a. a -> a
id
      (AnimationLayer -> Identity AnimationLayer)
-> AnimationLayer -> Identity AnimationLayer
forall a. a -> a
id ((AnimationLayer -> Identity AnimationLayer)
 -> AnimationLayer -> Identity AnimationLayer)
-> StateT AnimationLayer (LightT env m) AnimationLayer
-> StateT AnimationLayer (LightT env m) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> m b -> m ()
<~ LightT env m AnimationLayer
-> StateT AnimationLayer (LightT env m) AnimationLayer
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (AnimationLayer -> LightT env m AnimationLayer
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, HasLoopEnv env,
 HasComponentEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m c
update AnimationLayer
c)

  figures :: MessageLayer -> LightT env m [Figure]
figures comp :: MessageLayer
comp = do
    [Figure]
baseLayer <- Layer -> LightT env m [Figure]
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m [Figure]
figures (Layer -> LightT env m [Figure]) -> Layer -> LightT env m [Figure]
forall a b. (a -> b) -> a -> b
$ MessageLayer -> Layer
layer MessageLayer
comp
    [Figure]
cursorLayer <- AnimationLayer -> LightT env m [Figure]
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m [Figure]
figures (AnimationLayer -> LightT env m [Figure])
-> AnimationLayer -> LightT env m [Figure]
forall a b. (a -> b) -> a -> b
$ MessageLayer -> AnimationLayer
cursor MessageLayer
comp
    [Figure]
textLayer <- MessageEngine -> LightT env m [Figure]
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m [Figure]
figures (MessageEngine -> LightT env m [Figure])
-> MessageEngine -> LightT env m [Figure]
forall a b. (a -> b) -> a -> b
$ MessageLayer -> MessageEngine
messageEngine MessageLayer
comp

    let cursorSize :: V2 Int
cursorSize = AnimationLayer -> V2 Int
CAnim.tileSize (MessageLayer -> AnimationLayer
cursor MessageLayer
comp)
    let windowSize :: V2 Int
windowSize = Config -> V2 Int
Basic.size (Config -> V2 Int) -> Config -> V2 Int
forall a b. (a -> b) -> a -> b
$ Config -> Config
CLayer.basic (Config -> Config) -> Config -> Config
forall a b. (a -> b) -> a -> b
$ Config -> Config
window (Config -> Config) -> Config -> Config
forall a b. (a -> b) -> a -> b
$ MessageLayer -> Config
config MessageLayer
comp
    let position :: V2 Int
position = Config -> V2 Int
Basic.position (Config -> V2 Int) -> Config -> V2 Int
forall a b. (a -> b) -> a -> b
$ Config -> Config
CLayer.basic (Config -> Config) -> Config -> Config
forall a b. (a -> b) -> a -> b
$ Config -> Config
window (Config -> Config) -> Config -> Config
forall a b. (a -> b) -> a -> b
$ MessageLayer -> Config
config MessageLayer
comp

    [Figure] -> LightT env m [Figure]
forall (m :: * -> *) a. Monad m => a -> m a
return
      ([Figure] -> LightT env m [Figure])
-> [Figure] -> LightT env m [Figure]
forall a b. (a -> b) -> a -> b
$ [Figure]
baseLayer
      [Figure] -> [Figure] -> [Figure]
forall a. [a] -> [a] -> [a]
++ (Figure -> Figure) -> [Figure] -> [Figure]
forall a b. (a -> b) -> [a] -> [b]
map (V2 Int -> Figure -> Figure
forall r (m :: * -> *). Rendering r m => V2 Int -> r -> r
translate (V2 Int
position V2 Int -> V2 Int -> V2 Int
forall a. Num a => a -> a -> a
+ Int -> Int -> V2 Int
forall a. a -> a -> V2 a
Vect.V2 20 10)) [Figure]
textLayer
      [Figure] -> [Figure] -> [Figure]
forall a. [a] -> [a] -> [a]
++ (Figure -> Figure) -> [Figure] -> [Figure]
forall a b. (a -> b) -> [a] -> [b]
map (V2 Int -> Figure -> Figure
forall r (m :: * -> *). Rendering r m => V2 Int -> r -> r
translate (V2 Int
position V2 Int -> V2 Int -> V2 Int
forall a. Num a => a -> a -> a
+ Int -> Int -> V2 Int
forall a. a -> a -> V2 a
Vect.V2 ((V2 Int
windowSize V2 Int -> Getting Int (V2 Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (V2 Int) Int
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x Int -> Int -> Int
forall a. Num a => a -> a -> a
- V2 Int
cursorSize V2 Int -> Getting Int (V2 Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (V2 Int) Int
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2) (V2 Int
windowSize V2 Int -> Getting Int (V2 Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (V2 Int) Int
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y Int -> Int -> Int
forall a. Num a => a -> a -> a
- V2 Int
cursorSize V2 Int -> Getting Int (V2 Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (V2 Int) Int
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y))) [Figure]
cursorLayer

  onSignal :: Event -> MessageLayer -> LightT env m MessageLayer
onSignal
    = Lens' MessageLayer Config
-> (Event -> MessageLayer -> LightT env m MessageLayer)
-> Event
-> MessageLayer
-> LightT env m MessageLayer
forall env (m :: * -> *) c.
(HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m,
 ComponentUnit c) =>
Lens' c Config
-> (Event -> c -> LightT env m c) -> Event -> c -> LightT env m c
Basic.wrapSignal ((Config -> f Config) -> MessageLayer -> f MessageLayer
Lens' MessageLayer Config
_config ((Config -> f Config) -> MessageLayer -> f MessageLayer)
-> ((Config -> f Config) -> Config -> f Config)
-> (Config -> f Config)
-> MessageLayer
-> f MessageLayer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> f Config) -> Config -> f Config
forall c. HasConfig c => Lens' c Config
Basic.config)
    ((Event -> MessageLayer -> LightT env m MessageLayer)
 -> Event -> MessageLayer -> LightT env m MessageLayer)
-> (Event -> MessageLayer -> LightT env m MessageLayer)
-> Event
-> MessageLayer
-> LightT env m MessageLayer
forall a b. (a -> b) -> a -> b
$ Lens MessageLayer MessageLayer MessageEngine MessageEngine
-> (Event -> MessageLayer -> LightT env m MessageLayer)
-> Event
-> MessageLayer
-> LightT env m MessageLayer
forall env (m :: * -> *) c.
(HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m,
 MonadMask m) =>
Lens' c MessageEngine
-> (Event -> c -> LightT env m c) -> Event -> c -> LightT env m c
CME.wrapSignal Lens MessageLayer MessageLayer MessageEngine MessageEngine
_messageEngine
    ((Event -> MessageLayer -> LightT env m MessageLayer)
 -> Event -> MessageLayer -> LightT env m MessageLayer)
-> (Event -> MessageLayer -> LightT env m MessageLayer)
-> Event
-> MessageLayer
-> LightT env m MessageLayer
forall a b. (a -> b) -> a -> b
$ \ev :: Event
ev -> StateT MessageLayer (LightT env m) ()
-> MessageLayer -> LightT env m MessageLayer
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT MessageLayer (LightT env m) ()
 -> MessageLayer -> LightT env m MessageLayer)
-> StateT MessageLayer (LightT env m) ()
-> MessageLayer
-> LightT env m MessageLayer
forall a b. (a -> b) -> a -> b
$ case Event -> Maybe Signal
forall a. EventType a => Event -> Maybe a
asSignal Event
ev of
      Just (Basic.MouseReleased _) -> do
        MessageEngine
me <- Getting MessageEngine MessageLayer MessageEngine
-> StateT MessageLayer (LightT env m) MessageEngine
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting MessageEngine MessageLayer MessageEngine
Lens MessageLayer MessageLayer MessageEngine MessageEngine
_messageEngine

        if MessageEngine
me MessageEngine -> Getting Bool MessageEngine Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool MessageEngine Bool
Lens' MessageEngine Bool
CME._finished
          then LightT env m () -> StateT MessageLayer (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> StateT MessageLayer (LightT env m) ())
-> LightT env m () -> StateT MessageLayer (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ MessageLayerEvent -> LightT env m ()
forall env (m :: * -> *) et.
(HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et) =>
et -> LightT env m ()
emitGlobally MessageLayerEvent
Finish
          else LightT env m () -> StateT MessageLayer (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> StateT MessageLayer (LightT env m) ())
-> LightT env m () -> StateT MessageLayer (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ EngineEvent -> LightT env m ()
forall env (m :: * -> *) et.
(HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et) =>
et -> LightT env m ()
emitGlobally EngineEvent
CME.NextPage
      _ -> () -> StateT MessageLayer (LightT env m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

new :: Config -> MiniLight MessageLayer
new :: Config -> MiniLight MessageLayer
new conf :: Config
conf = do
  MessageEngine
engine <- Config -> MiniLight MessageEngine
CME.new (Config -> Config
engine Config
conf)
  Layer
layer  <- Config -> MiniLight Layer
CLayer.newNineTile (Config -> Config
window Config
conf)
  AnimationLayer
cursor <- Config -> MiniLight AnimationLayer
CAnim.new (Config -> Config
next Config
conf)

  MessageLayer -> MiniLight MessageLayer
forall (m :: * -> *) a. Monad m => a -> m a
return (MessageLayer -> MiniLight MessageLayer)
-> MessageLayer -> MiniLight MessageLayer
forall a b. (a -> b) -> a -> b
$ $WMessageLayer :: MessageEngine -> Layer -> AnimationLayer -> Config -> MessageLayer
MessageLayer
    { messageEngine :: MessageEngine
messageEngine = MessageEngine
engine
    , layer :: Layer
layer         = Layer
layer
    , cursor :: AnimationLayer
cursor        = AnimationLayer
cursor
    , config :: Config
config        = Config
conf
    }