module Data.Component.MessageEngine where
import Control.Lens
import Control.Lens.TH.Rules
import Control.Monad.State
import Control.Monad.Catch (MonadMask)
import Data.Aeson hiding ((.=))
import qualified Data.Config.Font as Font
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Typeable
import MiniLight
import qualified SDL
import qualified SDL.Font
import qualified SDL.Vect as Vect
data Config = Config {
messages :: V.Vector T.Text,
static :: Bool,
font :: Font.Config
}
makeLensesWith lensRules_ ''Config
instance FromJSON Config where
parseJSON = withObject "config" $ \v -> do
messages <- v .: "messages"
static <- v .:? "static" .!= False
font <- v .: "font"
return $ Config messages static font
data MessageEngine = MessageEngine {
fontData :: SDL.Font.Font,
counter :: Int,
page :: Int,
textCounter :: Int,
textTexture :: Figure,
finished :: Bool,
currentMessages :: V.Vector T.Text,
config :: Config
}
makeLensesWith lensRules_ ''MessageEngine
data EngineEvent where
NextPage :: EngineEvent
SetMessage
:: [T.Text]
-> EngineEvent
deriving Typeable
instance EventType EngineEvent where
getEventType NextPage = "next-page"
getEventType (SetMessage _) = "set-message"
instance ComponentUnit MessageEngine where
update = execStateT $ do
fin <- use _finished
unless fin $ do
cnt <- use _counter
when (cnt `mod` 10 == 0) $ do
_textCounter %= (+1)
tc <- use _textCounter
p <- use _page
messages <- use _currentMessages
when (p == V.length messages - 1 && tc == T.length (messages V.! p)) $ do
_finished .= True
_counter %= (+1)
figures comp = do
let messages = comp ^. _currentMessages
(w, h) <- SDL.Font.size (comp ^. _fontData) (T.take (comp ^. _textCounter) $ messages V.! (comp ^. _page))
return [
clip (SDL.Rectangle 0 (Vect.V2 w h)) $ textTexture comp
]
useCache c1 c2 = page c1 == page c2 && textCounter c1 == textCounter c2
onSignal ev = execStateT $ case asSignal ev of
Just NextPage -> do
fin <- use _finished
unless fin $ do
_page %= (+1)
_textCounter .= 0
font <- use _fontData
fontColor <- use $ _config . _font . Font._color
p <- use _page
messages <- use _currentMessages
tex <- lift $ liftMiniLight $ text font fontColor (messages V.! p)
_textTexture .= tex
Just (SetMessage ms) -> do
let vs = V.fromList ms
_counter .= 0
_page .= 0
st <- use $ _config . _static
_textCounter .= if st then T.length (vs V.! 0) else 0
font <- use _fontData
fontColor <- use $ _config . _font . Font._color
tex <- lift $ liftMiniLight $ text font fontColor $ vs V.! 0
_textTexture .= tex
_finished .= st
_currentMessages .= vs
_ -> return ()
new :: Config -> MiniLight MessageEngine
new conf = do
font <- Font.loadFontFrom (font conf)
textTexture <- text font (conf ^. _font ^. Font._color) $ messages conf V.! 0
return $ MessageEngine
{ fontData = font
, counter = 0
, page = 0
, textCounter = if static conf then T.length (messages conf V.! 0) else 0
, textTexture = textTexture
, finished = static conf
, currentMessages = messages conf
, config = conf
}
wrapSignal
:: ( HasLightEnv env
, HasLoopEnv env
, HasComponentEnv env
, MonadIO m
, MonadMask m
)
=> (Lens' c MessageEngine)
-> (Event -> c -> LightT env m c)
-> (Event -> c -> LightT env m c)
wrapSignal lens f ev = execStateT $ do
zoom lens $ do
st <- use id
st' <- lift $ onSignal ev st
id .= st'
st <- use id
st' <- lift $ f ev st
id .= st'