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 {
size :: Vect.V2 Int,
position :: Vect.V2 Int,
visible :: Bool
} deriving (Show)
makeClassy_ ''Config
defConfig :: Config
defConfig = Config {size = 0, position = 0, visible = True}
instance FromJSON Config where
parseJSON = withObject "config" $ \v -> do
sizeMaybe <- v .:? "size"
size <- (\w -> maybe (return 0) w sizeMaybe) $ withObject "size" $ \v ->
Vect.V2 <$> v .: "width" <*> v .: "height"
positionMaybe <- v .:? "position"
position <- (\w -> maybe (return 0) w positionMaybe) $ withObject "position" $ \v ->
Vect.V2 <$> v .: "x" <*> v .: "y"
visibleMaybe <- v .:? "visible"
let visible = maybe True id visibleMaybe
return $ Config size position visible
wrapConfig
:: (Config -> a -> Parser r) -> (Object -> Parser a) -> Value -> Parser r
wrapConfig f p = withObject "wrapConfig" $ \v -> do
other <- p v
conf <- parseJSON (Object v)
f conf other
areaRectangle :: Config -> SDL.Rectangle Int
areaRectangle conf = SDL.Rectangle (SDL.P (position conf)) (size 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 (MousePressed _) = "mouse-pressed"
getEventType (MouseReleased _) = "mouse-released"
getEventType (MouseOver _) = "mouse-over"
getEventType (SetVisibility _) = "set-visibility"
getEventProperties (SetVisibility o) = HM.fromList [("visibility", Bool o)]
getEventProperties _ = error "not implemeneted yet"
wrapFigures :: Config -> [Figure] -> [Figure]
wrapFigures conf fs =
if not (conf ^. _visible) then [] else map (translate (position conf)) 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 f ev comp = do
conf' <- handleBasicSignal ev (comp ^. lens)
when (comp ^. lens ^. _visible) $ emitBasicSignal ev conf'
f ev (comp & lens .~ conf')
emitBasicSignal
:: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m)
=> Event
-> Config
-> LightT env m ()
emitBasicSignal (RawEvent (SDL.Event _ (SDL.MouseMotionEvent (SDL.MouseMotionEventData _ _ _ (SDL.P pos) _)))) conf
| contains (areaRectangle conf) (fmap fromEnum pos)
= view _uid
>>= \t -> emit (Just t) $ MouseOver $ fmap fromEnum pos - position conf
emitBasicSignal (RawEvent (SDL.Event _ (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ state _ _ _ (SDL.P pos))))) conf
| contains (areaRectangle conf) (fmap fromEnum pos)
= view _uid >>= \t ->
emit (Just t)
$ ( case state of
SDL.Pressed -> MousePressed
SDL.Released -> MouseReleased
)
$ fmap fromEnum pos
- position conf
emitBasicSignal _ _ = return ()
handleBasicSignal
:: (HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m)
=> Event
-> Config
-> LightT env m Config
handleBasicSignal ev conf = case asSignal ev of
Just (SetVisibility b) -> return $ conf { visible = b }
_ -> return conf
contains :: (Ord a, Num a) => SDL.Rectangle a -> Vect.V2 a -> Bool
contains (SDL.Rectangle (Vect.P (Vect.V2 x y)) (Vect.V2 w h)) (Vect.V2 px py) =
x <= px && px <= x + w && y <= py && py <= y + h