{-| MiniLight module exports all basic concepts and oprations except for concrete components. -} module MiniLight ( module MiniLight.Light, module MiniLight.Event, module MiniLight.Figure, module MiniLight.Component, runLightT, LoopConfig (..), defConfig, LoopEnv (..), MiniLoop, runMainloop, ) where import Control.Concurrent (threadDelay) import Control.Monad.Catch import Control.Monad.Reader import qualified Data.Aeson as Aeson import Data.Foldable (foldlM) import Data.Hashable (Hashable(..)) import qualified Data.HashMap.Strict as HM import Data.IORef import qualified Data.Text as T import qualified Data.Vector.Mutable as VM import Graphics.Text.TrueType import Lens.Micro import Lens.Micro.Mtl import MiniLight.Component import MiniLight.Event import MiniLight.Figure import MiniLight.Light import qualified SDL import qualified SDL.Font instance Hashable SDL.Scancode where hashWithSalt n sc = hashWithSalt n (SDL.unwrapScancode sc) -- | Run a Light monad. runLightT :: (MonadIO m, MonadMask m) => LightT LightEnv m a -> m a runLightT prog = withSDL $ withWindow $ \window -> do renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer fc <- loadFontCache runReaderT (runLightT' prog) $ LightEnv {renderer = renderer, fontCache = fc} -- | Use 'defConfig' for a default setting. data LoopConfig = LoopConfig { watchKeys :: Maybe [SDL.Scancode], -- ^ Set @Nothing@ if all keys should be watched. See also 'LoopState'. appConfigFile :: Maybe FilePath, -- ^ Specify a yaml file which describes component settings. See 'MiniLight.Component' for the yaml syntax. componentResolver :: T.Text -> Aeson.Value -> MiniLight Component, -- ^ Your custom mappings between a component name and its type. additionalComponents :: [Component] -- ^ The components here would be added during the initialization. } -- | Default configurations for the mainloop. You need to set @componentResolver@ if you use a component. defConfig :: LoopConfig defConfig = LoopConfig { watchKeys = Nothing , appConfigFile = Nothing , componentResolver = \_ _ -> undefined , additionalComponents = [] } fromList :: MonadIO m => [a] -> m (VM.IOVector a) fromList xs = liftIO $ do vec <- VM.new $ length xs forM_ (zip [0 ..] xs) $ uncurry (VM.write vec) return vec -- | LoopEnv value would be passed to user side in a mainloop. data LoopEnv env = LoopState { env :: env, keyStates :: HM.HashMap SDL.Scancode Int, events :: IORef [Event], signalQueue :: IORef [Event], components :: VM.IOVector Component } -- | Lens to the env inside 'LoopState' envL :: Lens' (LoopEnv env) env envL = lens env (\e r -> e { env = r }) instance HasLightEnv env => HasLightEnv (LoopEnv env) where rendererL = envL . rendererL fontCacheL = envL . fontCacheL instance HasLoopEnv (LoopEnv env) where keyStatesL = lens keyStates (\env r -> env { keyStates = r }) eventsL = lens events (\env r -> env { events = r }) signalQueueL = lens signalQueue (\env r -> env { signalQueue = r }) instance HasLightEnv env => HasLightEnv (T.Text, env) where rendererL = _2 . rendererL fontCacheL = _2 . fontCacheL instance HasLoopEnv env => HasLoopEnv (T.Text, env) where keyStatesL = _2 . keyStatesL eventsL = _2 . eventsL signalQueueL = _2 . signalQueueL instance HasComponentEnv (T.Text, env) where uidL = _1 -- | Type synonym to the minimal type of the mainloop type MiniLoop = LightT (LoopEnv LightEnv) IO -- | Run a mainloop. -- In a mainloop, components and events are managed. -- -- Components in a mainloop: draw ~ update ~ (user-defined function) ~ event handling runMainloop :: ( HasLightEnv env , HasLightEnv loop , HasLoopEnv loop , MonadIO m , MonadMask m ) => (LoopEnv env -> loop) -- ^ LoopState conversion function (you can pass @id@, fixing @loop@ as @'LoopState' 'LightEnv'@) -> LoopConfig -- ^ loop config -> s -- ^ initial state -> (s -> LightT loop m s) -- ^ a function called in every loop -> LightT env m () runMainloop conv conf initial loop = do components <- liftMiniLight $ fromList . (++ additionalComponents conf) =<< maybe (return []) (flip loadAppConfig (componentResolver conf)) (appConfigFile conf) events <- liftIO $ newIORef [] signalQueue <- liftIO $ newIORef [] env <- view id go ( LoopState { keyStates = HM.empty , events = events , signalQueue = signalQueue , env = env , components = components } ) initial where go loopState s = do renderer <- view rendererL liftIO $ SDL.rendererDrawColor renderer SDL.$= 255 liftIO $ SDL.clear renderer forM_ [0 .. VM.length (components loopState) - 1] $ \i -> do comp <- liftIO $ VM.read (components loopState) i draw comp -- state propagation forM_ [0 .. VM.length (components loopState) - 1] $ \i -> do comp <- liftIO $ VM.read (components loopState) i liftIO $ VM.write (components loopState) i (propagate comp) forM_ [0 .. VM.length (components loopState) - 1] $ \i -> do comp <- liftIO $ VM.read (components loopState) i comp' <- envLightT (\env -> (getUID comp, conv $ loopState { env = env })) $ update comp liftIO $ VM.write (components loopState) i comp' s' <- envLightT (\env -> conv $ loopState { env = env }) $ loop s liftIO $ SDL.present renderer liftIO $ threadDelay (100000 `div` 60) events <- SDL.pollEvents keys <- SDL.getKeyboardState envLightT (\env -> conv $ loopState { env = env }) $ do evref <- view eventsL liftIO $ writeIORef evref $ map RawEvent events sigref <- view signalQueueL signals <- liftIO $ readIORef sigref liftIO $ modifyIORef evref $ (++ signals) liftIO $ writeIORef sigref [] envLightT (\env -> conv $ loopState { env = env }) $ do evref <- view eventsL events <- liftIO $ readIORef evref forM_ [0 .. VM.length (components loopState) - 1] $ \i -> do comp <- liftIO $ VM.read (components loopState) i comp' <- foldlM (\comp ev -> envLightT ((,) (getUID comp)) $ onSignal ev comp) comp events liftIO $ VM.write (components loopState) i comp' let specifiedKeys = HM.mapWithKey (\k v -> if keys k then v + 1 else 0) ( maybe id (\specified m -> HM.fromList $ map (\s -> (s, m HM.! s)) specified) (watchKeys conf) $ keyStates loopState ) let loopState' = loopState { keyStates = specifiedKeys } let quit = any ( \event -> case SDL.eventPayload event of SDL.WindowClosedEvent _ -> True SDL.QuitEvent -> True _ -> False ) events unless quit $ go loopState' s' -- withSDL :: (MonadIO m, MonadMask m) => m a -> m a withSDL = bracket (SDL.initializeAll >> SDL.Font.initialize) (\_ -> SDL.Font.quit >> SDL.quit) . const withWindow :: (MonadIO m, MonadMask m) => (SDL.Window -> m a) -> m a withWindow = bracket (SDL.createWindow "window" SDL.defaultWindow) SDL.destroyWindow