{-| The package provides the basics for all components in the library.

A component should have the followings (those can be omitted):

- position: @{x: int, y: int}@
- size: @{width: int, height: int}@
- color: @int[4]@
- font: @{family: string, bold: bool, italic: bool, size: int}@

-}
module Data.Component.Basic where

import Control.Lens hiding (contains)
import Control.Monad
import Data.Aeson
import Data.Aeson.Types
import qualified Data.HashMap.Strict as HM
import Data.Typeable
import qualified SDL
import qualified SDL.Vect as Vect
import MiniLight

-- | Basic config type
data Config = Config {
  Config -> V2 Int
size :: Vect.V2 Int,
  Config -> V2 Int
position :: Vect.V2 Int,
  Config -> Bool
visible :: Bool
} deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

makeClassy_ ''Config

defConfig :: Config
defConfig :: Config
defConfig = $WConfig :: V2 Int -> V2 Int -> Bool -> Config
Config {size :: V2 Int
size = 0, position :: V2 Int
position = 0, visible :: Bool
visible = Bool
True}

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
    Maybe Value
sizeMaybe <- Object
v Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "size"
    V2 Int
size <- (\w :: Value -> Parser (V2 Int)
w -> Parser (V2 Int)
-> (Value -> Parser (V2 Int)) -> Maybe Value -> Parser (V2 Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (V2 Int -> Parser (V2 Int)
forall (m :: * -> *) a. Monad m => a -> m a
return 0) Value -> Parser (V2 Int)
w Maybe Value
sizeMaybe) ((Value -> Parser (V2 Int)) -> Parser (V2 Int))
-> (Value -> Parser (V2 Int)) -> Parser (V2 Int)
forall a b. (a -> b) -> a -> b
$ String -> (Object -> Parser (V2 Int)) -> Value -> Parser (V2 Int)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "size" ((Object -> Parser (V2 Int)) -> Value -> Parser (V2 Int))
-> (Object -> Parser (V2 Int)) -> Value -> Parser (V2 Int)
forall a b. (a -> b) -> a -> b
$ \v :: Object
v ->
      Int -> Int -> V2 Int
forall a. a -> a -> V2 a
Vect.V2 (Int -> Int -> V2 Int) -> Parser Int -> Parser (Int -> V2 Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: "width" Parser (Int -> V2 Int) -> Parser Int -> Parser (V2 Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: "height"

    Maybe Value
positionMaybe <- Object
v Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "position"
    V2 Int
position <- (\w :: Value -> Parser (V2 Int)
w -> Parser (V2 Int)
-> (Value -> Parser (V2 Int)) -> Maybe Value -> Parser (V2 Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (V2 Int -> Parser (V2 Int)
forall (m :: * -> *) a. Monad m => a -> m a
return 0) Value -> Parser (V2 Int)
w Maybe Value
positionMaybe) ((Value -> Parser (V2 Int)) -> Parser (V2 Int))
-> (Value -> Parser (V2 Int)) -> Parser (V2 Int)
forall a b. (a -> b) -> a -> b
$ String -> (Object -> Parser (V2 Int)) -> Value -> Parser (V2 Int)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "position" ((Object -> Parser (V2 Int)) -> Value -> Parser (V2 Int))
-> (Object -> Parser (V2 Int)) -> Value -> Parser (V2 Int)
forall a b. (a -> b) -> a -> b
$ \v :: Object
v ->
      Int -> Int -> V2 Int
forall a. a -> a -> V2 a
Vect.V2 (Int -> Int -> V2 Int) -> Parser Int -> Parser (Int -> V2 Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: "x" Parser (Int -> V2 Int) -> Parser Int -> Parser (V2 Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: "y"

    Maybe Bool
visibleMaybe <- Object
v Object -> Text -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "visible"
    let visible :: Bool
visible = Bool -> (Bool -> Bool) -> Maybe Bool -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Bool -> Bool
forall a. a -> a
id Maybe Bool
visibleMaybe

    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
$ V2 Int -> V2 Int -> Bool -> Config
Config V2 Int
size V2 Int
position Bool
visible

-- | This wrapper function is useful when you write your component config parser.
wrapConfig
  :: (Config -> a -> Parser r) -> (Object -> Parser a) -> Value -> Parser r
wrapConfig :: (Config -> a -> Parser r)
-> (Object -> Parser a) -> Value -> Parser r
wrapConfig f :: Config -> a -> Parser r
f p :: Object -> Parser a
p = String -> (Object -> Parser r) -> Value -> Parser r
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "wrapConfig" ((Object -> Parser r) -> Value -> Parser r)
-> (Object -> Parser r) -> Value -> Parser r
forall a b. (a -> b) -> a -> b
$ \v :: Object
v -> do
  a
other <- Object -> Parser a
p Object
v
  Config
conf  <- Value -> Parser Config
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
v)
  Config -> a -> Parser r
f Config
conf a
other

-- | The rectangle region of the component.
areaRectangle :: Config -> SDL.Rectangle Int
areaRectangle :: Config -> Rectangle Int
areaRectangle conf :: Config
conf = Point V2 Int -> V2 Int -> Rectangle Int
forall a. Point V2 a -> V2 a -> Rectangle a
SDL.Rectangle (V2 Int -> Point V2 Int
forall (f :: * -> *) a. f a -> Point f a
SDL.P (Config -> V2 Int
position Config
conf)) (Config -> V2 Int
size Config
conf)

-- | Basic signal type.
data Signal where
  MousePressed
    :: Vect.V2 Int  -- ^ The relative position of the mouse pointer
    -> Signal
  MouseReleased
    :: Vect.V2 Int  -- ^ The relative position of the mouse pointer
    -> Signal
  MouseOver
    :: Vect.V2 Int  -- ^ The relative position of the mouse pointer
    -> Signal
  SetVisibility :: Bool -> Signal
  deriving Typeable

instance EventType Signal where
  getEventType :: Signal -> Text
getEventType (MousePressed _) = "mouse-pressed"
  getEventType (MouseReleased _) = "mouse-released"
  getEventType (MouseOver _) = "mouse-over"
  getEventType (SetVisibility _) = "set-visibility"

  getEventProperties :: Signal -> Object
getEventProperties (SetVisibility o :: Bool
o) = [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [("visibility", Bool -> Value
Bool Bool
o)]
  getEventProperties _ = String -> Object
forall a. HasCallStack => String -> a
error "not implemeneted yet"

-- | This automatically applies basic configuration such as: position.
wrapFigures :: Config -> [Figure] -> [Figure]
wrapFigures :: Config -> [Figure] -> [Figure]
wrapFigures conf :: Config
conf fs :: [Figure]
fs =
  if Bool -> Bool
not (Config
conf Config -> Getting Bool Config Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Config Bool
forall c. HasConfig c => Lens' c Bool
_visible) then [] else (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 (Config -> V2 Int
position Config
conf)) [Figure]
fs

-- | This wrapper function is useful when you write your own 'onSignal' component.
wrapSignal
  :: ( HasLightEnv env
     , HasLoopEnv env
     , HasComponentEnv env
     , MonadIO m
     , ComponentUnit c
     )
  => Lens' c Config  -- ^ lens to 'Config'
  -> (Event -> c -> LightT env m c)  -- ^ custom @onSignal@ function
  -> (Event -> c -> LightT env m c)
wrapSignal :: Lens' c Config
-> (Event -> c -> LightT env m c) -> Event -> c -> LightT env m c
wrapSignal lens :: Lens' c Config
lens f :: Event -> c -> LightT env m c
f ev :: Event
ev comp :: c
comp = do
  Config
conf' <- Event -> Config -> LightT env m Config
forall env (m :: * -> *).
(HasLightEnv env, HasLoopEnv env, HasComponentEnv env,
 MonadIO m) =>
Event -> Config -> LightT env m Config
handleBasicSignal Event
ev (c
comp c -> Getting Config c Config -> Config
forall s a. s -> Getting a s a -> a
^. Getting Config c Config
Lens' c Config
lens)

  Bool -> LightT env m () -> LightT env m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (c
comp c -> Getting Config c Config -> Config
forall s a. s -> Getting a s a -> a
^. Getting Config c Config
Lens' c Config
lens Config -> Getting Bool Config Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Config Bool
forall c. HasConfig c => Lens' c Bool
_visible) (LightT env m () -> LightT env m ())
-> LightT env m () -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ Event -> Config -> LightT env m ()
forall env (m :: * -> *).
(HasLightEnv env, HasLoopEnv env, HasComponentEnv env,
 MonadIO m) =>
Event -> Config -> LightT env m ()
emitBasicSignal Event
ev Config
conf'
  Event -> c -> LightT env m c
f Event
ev (c
comp c -> (c -> c) -> c
forall a b. a -> (a -> b) -> b
& (Config -> Identity Config) -> c -> Identity c
Lens' c Config
lens ((Config -> Identity Config) -> c -> Identity c)
-> Config -> c -> c
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Config
conf')

-- | Basic signaling function. Signals are emitted towards the source component.
emitBasicSignal
  :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m)
  => Event
  -> Config
  -> LightT env m ()
emitBasicSignal :: Event -> Config -> LightT env m ()
emitBasicSignal (RawEvent (SDL.Event _ (SDL.MouseMotionEvent (SDL.MouseMotionEventData _ _ _ (SDL.P pos :: V2 Int32
pos) _)))) conf :: Config
conf
  | Rectangle Int -> V2 Int -> Bool
forall a. (Ord a, Num a) => Rectangle a -> V2 a -> Bool
contains (Config -> Rectangle Int
areaRectangle Config
conf) ((Int32 -> Int) -> V2 Int32 -> V2 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> Int
forall a. Enum a => a -> Int
fromEnum V2 Int32
pos)
  = Getting Text env Text -> LightT env m Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text env Text
forall c. HasComponentEnv c => Lens' c Text
_uid
    LightT env m Text -> (Text -> LightT env m ()) -> LightT env m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \t :: Text
t -> Maybe Text -> Signal -> LightT env m ()
forall env (m :: * -> *) et.
(HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et) =>
Maybe Text -> et -> LightT env m ()
emit (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t) (Signal -> LightT env m ()) -> Signal -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ V2 Int -> Signal
MouseOver (V2 Int -> Signal) -> V2 Int -> Signal
forall a b. (a -> b) -> a -> b
$ (Int32 -> Int) -> V2 Int32 -> V2 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> Int
forall a. Enum a => a -> Int
fromEnum V2 Int32
pos V2 Int -> V2 Int -> V2 Int
forall a. Num a => a -> a -> a
- Config -> V2 Int
position Config
conf
emitBasicSignal (RawEvent (SDL.Event _ (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ state :: InputMotion
state _ _ _ (SDL.P pos :: V2 Int32
pos))))) conf :: Config
conf
  | Rectangle Int -> V2 Int -> Bool
forall a. (Ord a, Num a) => Rectangle a -> V2 a -> Bool
contains (Config -> Rectangle Int
areaRectangle Config
conf) ((Int32 -> Int) -> V2 Int32 -> V2 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> Int
forall a. Enum a => a -> Int
fromEnum V2 Int32
pos)
  = Getting Text env Text -> LightT env m Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text env Text
forall c. HasComponentEnv c => Lens' c Text
_uid LightT env m Text -> (Text -> LightT env m ()) -> LightT env m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \t :: Text
t ->
    Maybe Text -> Signal -> LightT env m ()
forall env (m :: * -> *) et.
(HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et) =>
Maybe Text -> et -> LightT env m ()
emit (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t)
      (Signal -> LightT env m ()) -> Signal -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ ( case InputMotion
state of
          SDL.Pressed  -> V2 Int -> Signal
MousePressed
          SDL.Released -> V2 Int -> Signal
MouseReleased
        )
      (V2 Int -> Signal) -> V2 Int -> Signal
forall a b. (a -> b) -> a -> b
$ (Int32 -> Int) -> V2 Int32 -> V2 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> Int
forall a. Enum a => a -> Int
fromEnum V2 Int32
pos
      V2 Int -> V2 Int -> V2 Int
forall a. Num a => a -> a -> a
- Config -> V2 Int
position Config
conf
emitBasicSignal _ _ = () -> LightT env m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | handle basic signals
handleBasicSignal
  :: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m)
  => Event
  -> Config
  -> LightT env m Config
handleBasicSignal :: Event -> Config -> LightT env m Config
handleBasicSignal ev :: Event
ev conf :: Config
conf = case Event -> Maybe Signal
forall a. EventType a => Event -> Maybe a
asSignal Event
ev of
  Just (SetVisibility b :: Bool
b) -> Config -> LightT env m Config
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> LightT env m Config) -> Config -> LightT env m Config
forall a b. (a -> b) -> a -> b
$ Config
conf { visible :: Bool
visible = Bool
b }
  _                      -> Config -> LightT env m Config
forall (m :: * -> *) a. Monad m => a -> m a
return Config
conf

contains :: (Ord a, Num a) => SDL.Rectangle a -> Vect.V2 a -> Bool
contains :: Rectangle a -> V2 a -> Bool
contains (SDL.Rectangle (Vect.P (Vect.V2 x :: a
x y :: a
y)) (Vect.V2 w :: a
w h :: a
h)) (Vect.V2 px :: a
px py :: a
py) =
  a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
px Bool -> Bool -> Bool
&& a
px a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
w Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
py Bool -> Bool -> Bool
&& a
py a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y a -> a -> a
forall a. Num a => a -> a -> a
+ a
h