{-| 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 Data.Aeson import Data.Aeson.Types import Data.Typeable import Data.Word (Word8) import qualified SDL import qualified SDL.Vect as Vect import qualified SDL.Font import MiniLight -- | Basic config type data Config = Config { size :: Vect.V2 Int, position :: Vect.V2 Int, color :: Vect.V4 Word8, fontDesc :: FontDescriptor, fontSize :: Int } 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" color <- fmap (\[r,g,b,a] -> Vect.V4 r g b a) $ v .:? "color" .!= [255, 255, 255, 255] fontMaybe <- v .:? "font" (fontDesc, fontSize) <- (\w -> maybe (return (FontDescriptor "" (FontStyle False False), 0)) w fontMaybe) $ withObject "font" $ \v -> do family <- v .: "family" size <- v .: "size" bold <- v .:? "bold" .!= False italic <- v .:? "italic" .!= False return $ (FontDescriptor family (FontStyle bold italic), size) return $ Config size position color fontDesc fontSize -- | Load a system font from 'Config' type. loadFontFrom :: Config -> MiniLight SDL.Font.Font loadFontFrom conf = loadFont (fontDesc conf) (fontSize conf) -- | This wrapper function is useful when you write your component config parser. 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 -- | The rectangle region of the component. areaRectangle :: Config -> SDL.Rectangle Int areaRectangle conf = SDL.Rectangle (SDL.P (position conf)) (size 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 deriving Typeable instance EventType Signal -- | This wrapper function is useful when you write your own 'onSignal' component. wrapSignal :: ( HasLightEnv env , HasLoopEnv env , HasComponentEnv env , MonadIO m , ComponentUnit c ) => (c -> Config) -- ^ 'Config' getter -> (Event -> c -> LightT env m c) -- ^ Custom @onSignal@ function -> (Event -> c -> LightT env m c) wrapSignal getter f ev comp = do emitBasicSignal ev (getter comp) f ev comp -- | Basic signaling function. 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) = emit $ 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) = emit $ ( case state of SDL.Pressed -> MousePressed SDL.Released -> MouseReleased ) $ fmap fromEnum pos - position conf emitBasicSignal _ _ = return () 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