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
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
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
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)
data Signal where
MousePressed
:: Vect.V2 Int
-> Signal
MouseReleased
:: Vect.V2 Int
-> Signal
MouseOver
:: Vect.V2 Int
-> 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"
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
wrapSignal
:: ( 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)
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')
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 ()
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