module Data.Component.Layer where import Control.Lens import Control.Lens.TH.Rules import Control.Monad import Data.Aeson import Linear import MiniLight import qualified SDL import qualified SDL.Vect as Vect import qualified Data.Component.Basic as Basic data Config = Config { Config -> Config basic :: Basic.Config, Config -> FilePath image :: FilePath } instance FromJSON Config where parseJSON :: Value -> Parser Config parseJSON = (Config -> FilePath -> Parser Config) -> (Object -> Parser FilePath) -> Value -> Parser Config forall a r. (Config -> a -> Parser r) -> (Object -> Parser a) -> Value -> Parser r Basic.wrapConfig (\b :: Config b l :: FilePath l -> 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 -> FilePath -> Config Config Config b FilePath l) ((Object -> Parser FilePath) -> Value -> Parser Config) -> (Object -> Parser FilePath) -> Value -> Parser Config forall a b. (a -> b) -> a -> b $ \v :: Object v -> Object v Object -> Text -> Parser FilePath forall a. FromJSON a => Object -> Text -> Parser a .: "image" data Layer = Layer { Layer -> Figure layer :: Figure, Layer -> Config config :: Config } makeLensesWith lensRules_ ''Config makeLensesWith lensRules_ ''Layer instance Basic.HasConfig Config where config :: (Config -> f Config) -> Config -> f Config config = (Config -> f Config) -> Config -> f Config Lens' Config Config _basic instance ComponentUnit Layer where figures :: Layer -> LightT env m [Figure] figures comp :: Layer 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 $ Config -> [Figure] -> [Figure] Basic.wrapFigures (Config -> Config basic (Config -> Config) -> Config -> Config forall a b. (a -> b) -> a -> b $ Layer -> Config config Layer comp) [Layer -> Figure layer Layer comp] onSignal :: Event -> Layer -> LightT env m Layer onSignal = Lens' Layer Config -> (Event -> Layer -> LightT env m Layer) -> Event -> Layer -> LightT env m Layer 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) -> Layer -> f Layer Lens' Layer Config _config ((Config -> f Config) -> Layer -> f Layer) -> ((Config -> f Config) -> Config -> f Config) -> (Config -> f Config) -> Layer -> f Layer 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) (\_ -> Layer -> LightT env m Layer forall (m :: * -> *) a. Monad m => a -> m a return) useCache :: Layer -> Layer -> Bool useCache _ _ = Bool True new :: Config -> MiniLight Layer new :: Config -> MiniLight Layer new conf :: Config conf = do Figure pic <- FilePath -> LightT LightEnv IO Figure forall r (m :: * -> *). Rendering r m => FilePath -> m r picture (Config -> FilePath image Config conf) Layer -> MiniLight Layer forall (m :: * -> *) a. Monad m => a -> m a return (Layer -> MiniLight Layer) -> Layer -> MiniLight Layer forall a b. (a -> b) -> a -> b $ $WLayer :: Figure -> Config -> Layer Layer { layer :: Figure layer = Figure pic , config :: Config config = Config conf { basic :: Config basic = (Config -> Config basic Config conf) { size :: V2 Int Basic.size = Figure -> V2 Int getFigureSize Figure pic } } } newNineTile :: Config -> MiniLight Layer newNineTile :: Config -> MiniLight Layer newNineTile conf :: Config conf = do Maybe Renderer mrenderer <- Getting (Maybe Renderer) LightEnv (Maybe Renderer) -> LightT LightEnv IO (Maybe Renderer) forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a view Getting (Maybe Renderer) LightEnv (Maybe Renderer) forall c. HasLightEnv c => Lens' c (Maybe Renderer) _renderer Maybe Texture target <- ((Renderer -> LightT LightEnv IO Texture) -> Maybe Renderer -> LightT LightEnv IO (Maybe Texture)) -> Maybe Renderer -> (Renderer -> LightT LightEnv IO Texture) -> LightT LightEnv IO (Maybe Texture) forall a b c. (a -> b -> c) -> b -> a -> c flip (Renderer -> LightT LightEnv IO Texture) -> Maybe Renderer -> LightT LightEnv IO (Maybe Texture) forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Maybe Renderer mrenderer ((Renderer -> LightT LightEnv IO Texture) -> LightT LightEnv IO (Maybe Texture)) -> (Renderer -> LightT LightEnv IO Texture) -> LightT LightEnv IO (Maybe Texture) forall a b. (a -> b) -> a -> b $ \renderer :: Renderer renderer -> do Figure pic <- FilePath -> LightT LightEnv IO Figure forall r (m :: * -> *). Rendering r m => FilePath -> m r picture (FilePath -> LightT LightEnv IO Figure) -> FilePath -> LightT LightEnv IO Figure forall a b. (a -> b) -> a -> b $ Config -> FilePath image Config conf let siz :: V2 CInt siz = (Int -> CInt) -> V2 Int -> V2 CInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Int -> CInt forall a. Enum a => Int -> a toEnum (V2 Int -> V2 CInt) -> V2 Int -> V2 CInt forall a b. (a -> b) -> a -> b $ Config -> V2 Int Basic.size (Config -> V2 Int) -> Config -> V2 Int forall a b. (a -> b) -> a -> b $ Config -> Config basic Config conf let Just tex :: Texture tex = Figure -> Maybe Texture texture Figure pic let texSize :: V2 CInt texSize = (Int -> CInt) -> V2 Int -> V2 CInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Int -> CInt forall a. Enum a => Int -> a toEnum (V2 Int -> V2 CInt) -> V2 Int -> V2 CInt forall a b. (a -> b) -> a -> b $ Figure -> V2 Int getFigureSize Figure pic TextureInfo tinfo <- Texture -> LightT LightEnv IO TextureInfo forall (m :: * -> *). MonadIO m => Texture -> m TextureInfo SDL.queryTexture Texture tex Texture target <- Renderer -> PixelFormat -> TextureAccess -> V2 CInt -> LightT LightEnv IO Texture forall (m :: * -> *). (Functor m, MonadIO m) => Renderer -> PixelFormat -> TextureAccess -> V2 CInt -> m Texture SDL.createTexture Renderer renderer (TextureInfo -> PixelFormat SDL.texturePixelFormat TextureInfo tinfo) TextureAccess SDL.TextureAccessTarget V2 CInt siz Renderer -> StateVar (Maybe Texture) SDL.rendererRenderTarget Renderer renderer StateVar (Maybe Texture) -> Maybe Texture -> LightT LightEnv IO () forall t a (m :: * -> *). (HasSetter t a, MonadIO m) => t -> a -> m () SDL.$= Texture -> Maybe Texture forall a. a -> Maybe a Just Texture target Texture -> StateVar BlendMode SDL.textureBlendMode Texture target StateVar BlendMode -> BlendMode -> LightT LightEnv IO () forall t a (m :: * -> *). (HasSetter t a, MonadIO m) => t -> a -> m () SDL.$= BlendMode SDL.BlendAlphaBlend let tileSize :: V2 CInt tileSize = (CInt -> CInt) -> V2 CInt -> V2 CInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (CInt -> CInt -> CInt forall a. Integral a => a -> a -> a `div` 3) V2 CInt texSize [CInt] -> (CInt -> LightT LightEnv IO ()) -> LightT LightEnv IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [0 .. 2] ((CInt -> LightT LightEnv IO ()) -> LightT LightEnv IO ()) -> (CInt -> LightT LightEnv IO ()) -> LightT LightEnv IO () forall a b. (a -> b) -> a -> b $ \ix :: CInt ix -> [CInt] -> (CInt -> LightT LightEnv IO ()) -> LightT LightEnv IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ [0 .. 2] ((CInt -> LightT LightEnv IO ()) -> LightT LightEnv IO ()) -> (CInt -> LightT LightEnv IO ()) -> LightT LightEnv IO () forall a b. (a -> b) -> a -> b $ \iy :: CInt iy -> do let targetSize :: V2 CInt targetSize = CInt -> CInt -> V2 CInt forall a. a -> a -> V2 a V2 (if CInt ix CInt -> CInt -> Bool forall a. Eq a => a -> a -> Bool == 1 then V2 CInt siz V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R1 t => Lens' (t a) a _x CInt -> CInt -> CInt forall a. Num a => a -> a -> a - 2 CInt -> CInt -> CInt forall a. Num a => a -> a -> a * V2 CInt tileSize V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R1 t => Lens' (t a) a _x else V2 CInt tileSize V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R1 t => Lens' (t a) a _x) (if CInt iy CInt -> CInt -> Bool forall a. Eq a => a -> a -> Bool == 1 then V2 CInt siz V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R2 t => Lens' (t a) a _y CInt -> CInt -> CInt forall a. Num a => a -> a -> a - 2 CInt -> CInt -> CInt forall a. Num a => a -> a -> a * V2 CInt tileSize V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R2 t => Lens' (t a) a _y else V2 CInt tileSize V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R2 t => Lens' (t a) a _y) let targetLoc :: V2 CInt targetLoc = CInt -> CInt -> V2 CInt forall a. a -> a -> V2 a V2 ( if CInt ix CInt -> CInt -> Bool forall a. Eq a => a -> a -> Bool == 0 then 0 else if CInt ix CInt -> CInt -> Bool forall a. Eq a => a -> a -> Bool == 1 then V2 CInt tileSize V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R1 t => Lens' (t a) a _x else V2 CInt siz V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R1 t => Lens' (t a) a _x CInt -> CInt -> CInt forall a. Num a => a -> a -> a - V2 CInt tileSize V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R1 t => Lens' (t a) a _x ) ( if CInt iy CInt -> CInt -> Bool forall a. Eq a => a -> a -> Bool == 0 then 0 else if CInt iy CInt -> CInt -> Bool forall a. Eq a => a -> a -> Bool == 1 then V2 CInt tileSize V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R2 t => Lens' (t a) a _y else V2 CInt siz V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R2 t => Lens' (t a) a _y CInt -> CInt -> CInt forall a. Num a => a -> a -> a - V2 CInt tileSize V2 CInt -> Getting CInt (V2 CInt) CInt -> CInt forall s a. s -> Getting a s a -> a ^. Getting CInt (V2 CInt) CInt forall (t :: * -> *) a. R2 t => Lens' (t a) a _y ) Renderer -> Texture -> Maybe (Rectangle CInt) -> Maybe (Rectangle CInt) -> LightT LightEnv IO () forall (m :: * -> *). MonadIO m => Renderer -> Texture -> Maybe (Rectangle CInt) -> Maybe (Rectangle CInt) -> m () SDL.copy Renderer renderer Texture tex (Rectangle CInt -> Maybe (Rectangle CInt) forall a. a -> Maybe a Just (Rectangle CInt -> Maybe (Rectangle CInt)) -> Rectangle CInt -> Maybe (Rectangle CInt) forall a b. (a -> b) -> a -> b $ Point V2 CInt -> V2 CInt -> Rectangle CInt forall a. Point V2 a -> V2 a -> Rectangle a SDL.Rectangle (V2 CInt -> Point V2 CInt forall (f :: * -> *) a. f a -> Point f a SDL.P (V2 CInt tileSize V2 CInt -> V2 CInt -> V2 CInt forall a. Num a => a -> a -> a * CInt -> CInt -> V2 CInt forall a. a -> a -> V2 a Vect.V2 CInt ix CInt iy)) V2 CInt tileSize) (Rectangle CInt -> Maybe (Rectangle CInt) forall a. a -> Maybe a Just (Rectangle CInt -> Maybe (Rectangle CInt)) -> Rectangle CInt -> Maybe (Rectangle CInt) forall a b. (a -> b) -> a -> b $ Point V2 CInt -> V2 CInt -> Rectangle CInt forall a. Point V2 a -> V2 a -> Rectangle a SDL.Rectangle (V2 CInt -> Point V2 CInt forall (f :: * -> *) a. f a -> Point f a SDL.P V2 CInt targetLoc) V2 CInt targetSize) Renderer -> StateVar (Maybe Texture) SDL.rendererRenderTarget Renderer renderer StateVar (Maybe Texture) -> Maybe Texture -> LightT LightEnv IO () forall t a (m :: * -> *). (HasSetter t a, MonadIO m) => t -> a -> m () SDL.$= Maybe Texture forall a. Maybe a Nothing Texture -> LightT LightEnv IO Texture forall (m :: * -> *) a. Monad m => a -> m a return Texture target Figure tex <- LightT LightEnv IO Figure -> (Texture -> LightT LightEnv IO Figure) -> Maybe Texture -> LightT LightEnv IO Figure forall b a. b -> (a -> b) -> Maybe a -> b maybe (Figure -> LightT LightEnv IO Figure forall (m :: * -> *) a. Monad m => a -> m a return Figure emptyFigure) Texture -> LightT LightEnv IO Figure forall r (m :: * -> *). Rendering r m => Texture -> m r fromTexture Maybe Texture target Layer -> MiniLight Layer forall (m :: * -> *) a. Monad m => a -> m a return (Layer -> MiniLight Layer) -> Layer -> MiniLight Layer forall a b. (a -> b) -> a -> b $ $WLayer :: Figure -> Config -> Layer Layer {layer :: Figure layer = Figure tex, config :: Config config = Config conf}