packages feed

minilight (empty) → 0.1.0

raw patch · 19 files changed

+1510/−0 lines, 19 filesdep +FontyFruitydep +aesondep +basesetup-changed

Dependencies added: FontyFruity, aeson, base, containers, exceptions, hashable, linear, microlens, microlens-mtl, minilight, mtl, mwc-random, scientific, sdl2, sdl2-gfx, sdl2-image, sdl2-ttf, tasty, tasty-hspec, template-haskell, text, trifecta, unordered-containers, vector, yaml

Files

+ CHANGELOG.md view
@@ -0,0 +1,10 @@+# Revision history for minilight++## 0.1.0 -- 2019-04-14++* First version.+* New features:+    * Mainloop management+    * Pre-defined Components+    * Config loader+    * Some examples
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2019 myuon++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/boids.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings #-}+import MiniLight+import Control.Monad.State+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as VM+import Lens.Micro+import Linear (_x, _y)+import qualified System.Random.MWC as Random+import qualified SDL.Vect as Vect++average :: (Fractional a, Num a) => V.Vector a -> a+average xs = (/ fromIntegral (V.length xs)) $ V.sum xs++data Object = Object {+  position :: Vect.V2 Double,+  velocity :: Vect.V2 Double+}++distance :: Object -> Object -> Double+distance o1 o2 = Vect.distance (position o1) (position o2)++data Game = Game {+  objects :: VM.IOVector Object,+  pic :: Figure+}++numberOfObjects = 100++width :: Int+width = 800++height :: Int+height = 600++mainloop :: StateT Game MiniLight ()+mainloop = do+  Game { objects = objects, pic = pic } <- get++  lift $ (renders =<<) $ forM [0 .. VM.length objects - 1] $ \i -> do+    object <- liftIO $ VM.read objects i+    return+      $ translate (fmap floor $ position object)+      $ rotate (let Vect.V2 x y = velocity object in pi - atan2 x y)+      $ pic++  lift $ forM_ [0 .. VM.length objects - 1] $ \i -> do+    object <- liftIO $ VM.read objects i++    let position'     = position object + 0.2 Vect.*^ velocity object+    let Vect.V2 vx vy = velocity object++    liftIO $ VM.write objects i $ do+      object+        { position = position'+        , velocity = Vect.V2+          ( if position' ^. _x < 0+            then abs vx+            else if position' ^. _x > fromIntegral width then -abs vx else vx+          )+          ( if position' ^. _y < 0+            then abs vy+            else if position' ^. _y > fromIntegral height then -abs vy else vy+          )+        }++  objs <- liftIO $ V.freeze objects+  lift $ forM_ [0 .. VM.length objects - 1] $ \i -> do+    let radius = 20+    let neighbors = V.filter+          ( \o ->+            0 < distance o (objs V.! i) && distance o (objs V.! i) < radius+          )+          objs++    object <- liftIO $ VM.read objects i++    when (not $ null neighbors) $ do+      -- separation+      let v1 = average $ V.map+            ( \n ->+              let diff = position object - position n+              in  (1 / Vect.dot diff diff) Vect.*^ diff+            )+            neighbors++      -- alignment+      let v2     = average $ V.map velocity neighbors++      -- cohesion+      let center = average $ V.map position neighbors+      let v3     = (1 / radius / radius) Vect.*^ (center - position object)++      liftIO $ VM.write objects i $ object+        { velocity = Vect.normalize $ velocity object + v1 + v2 + v3+        }++main :: IO ()+main = do+  vec <- Random.withSystemRandom . Random.asGenIO $ \gen ->+    Random.uniformVector gen numberOfObjects :: IO+        (V.Vector (Double, Double, Double, Double))+  objs <- V.thaw $ V.map+    ( \(p1, p2, v1, v2) -> Object+      ( fmap fromIntegral $ Vect.V2+        (floor (p1 * fromIntegral width) `mod` width)+        (floor (p2 * fromIntegral height) `mod` height)+      )+      (Vect.normalize $ Vect.V2 v1 v2)+    )+    vec++  runLightT id $ do+    pic <- triangleOutline (Vect.V4 100 100 100 255) (Vect.V2 10 20)++    runMainloop+      (defConfig { appConfigFile = Nothing, additionalComponents = [] })+      (Game {objects = objs, pic = pic})+      (\_ -> execStateT mainloop)
+ examples/button-counter.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}+import MiniLight+import qualified Data.Text as T+import qualified SDL+import qualified SDL.Font+import qualified SDL.Vect as Vect++data Button = Button {+  font :: SDL.Font.Font,+  counter :: Int+}++instance ComponentUnit Button where+  update = return++  figures comp = do+    textTexture <- liftMiniLight $ text (font comp) (Vect.V4 255 255 255 255) $+      if counter comp == 0 then "Click me!" else "You've clicked " `T.append` T.pack (show (counter comp)) `T.append` " times!"+    base <- liftMiniLight $ rectangleFilled (Vect.V4 60 60 60 255) (getFigureSize textTexture)++    return [+      base,+      textTexture+      ]++  useCache prev now = counter prev == counter now++  onSignal (RawEvent (SDL.Event _ (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Released _ _ _ _)))) comp = do+    return $ comp { counter = counter comp + 1 }+  onSignal _ comp = return comp++new :: MiniLight Button+new = do+  font <- loadFont (FontDescriptor "IPAGothic" (FontStyle False False)) 22+  return $ Button {font = font, counter = 0}++main :: IO ()+main = do+  runLightT id $ do+    button <- newComponent =<< new++    runMainloop+      (defConfig { appConfigFile = Nothing, additionalComponents = [button] })+      ()+      (\_ -> return)
+ minilight.cabal view
@@ -0,0 +1,125 @@+cabal-version:       2.4+-- Initial package description 'minilight.cabal' generated by 'cabal init'.+--   For further documentation, see http://haskell.org/cabal/users-guide/++name:                minilight+version:             0.1.0+synopsis:            A SDL2-based graphics library, batteries-included.+description:+  This package provides the wheel for a graphical application or a game.+  .+  Basic concepts and features:+  .+  - Figure: convenient SDL texture, once created, it can be translated or rotated during rendering.+  - Component: a reusable widget with event handlers, its figures can also be cached.+  - dynamic component loading: view components can be constructed by an external yaml file.+  - built-in components: some common components are predefined. You can define a new component by yourself.++-- bug-reports:+license:             MIT+license-file:        LICENSE+author:              myuon+maintainer:          ioi.joi.koi.loi@gmail.com+-- copyright:+category:            Graphics+extra-source-files:  CHANGELOG.md++source-repository head+  type:     git+  location: https://github.com/myuon/minilight.git++library+  exposed-modules:+    MiniLight+    MiniLight.Figure+    MiniLight.Light+    MiniLight.Event+    MiniLight.Component+    MiniLight.Component.Types+    MiniLight.Component.Loader+    MiniLight.Component.Layer+    MiniLight.Component.AnimationLayer+    MiniLight.Component.MessageEngine+    MiniLight.Component.MessageLayer+    MiniLight.Component.Button+  -- other-modules:+  -- other-extensions:+  build-depends:+    FontyFruity          >= 0.5.3 && < 0.6,+    base                 >= 4.12.0 && < 4.13,+    containers           >= 0.6.0 && < 0.7,+    text                 >= 1.2.3 && < 1.3,+    vector               >= 0.12.0 && < 0.13,+    aeson                >= 1.4.2 && < 1.5,+    scientific           >= 0.3.6 && < 0.4,+    hashable             >= 1.2.7 && < 1.3,+    template-haskell     >= 2.14.0 && < 2.15,+    unordered-containers >= 0.2.10 && < 0.3,+    exceptions           >= 0.10.1 && < 0.11,+    mtl                  >= 2.2.2 && < 2.3,+    linear               >= 1.20.8 && < 1.21,+    microlens            >= 0.4.10 && < 0.5,+    microlens-mtl        >= 0.1.11 && < 0.2,+    sdl2                 >= 2.4.1 && < 2.5,+    sdl2-gfx             >= 0.2 && < 0.3,+    sdl2-image           >= 2.0.0 && < 2.1,+    sdl2-ttf             >= 2.1.0 && < 2.2,+    trifecta             >= 2 && < 2.1,+    yaml                 >= 0.11.0 && < 0.12,+    mwc-random           >= 0.14.0 && < 0.15,+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions: +    FlexibleContexts+    FlexibleInstances+    GADTs+    OverloadedStrings+    MultiParamTypeClasses+    RankNTypes+    Strict+  ghc-options: -Wall -Wno-name-shadowing++test-suite tests+  type: exitcode-stdio-1.0+  main-is: Driver.hs+  build-tool-depends:+    tasty-discover:tasty-discover >= 4.2 && < 4.3,+  build-depends:+    aeson,+    base,+    minilight,+    tasty,+    tasty-hspec,+    trifecta,+    yaml,+  hs-source-dirs:      test+  default-language:    Haskell2010++executable button-counter+  hs-source-dirs: examples+  main-is: button-counter.hs+  default-language:    Haskell2010+  build-depends:+    base,+    minilight,+    sdl2,+    sdl2-ttf,+    text,+  ghc-options: -Wall -Wno-name-shadowing++executable boids+  hs-source-dirs: examples+  main-is: boids.hs+  default-language:    Haskell2010+  build-depends:+    base,+    linear,+    microlens,+    minilight,+    mtl,+    mwc-random,+    sdl2,+    sdl2-ttf,+    text,+    vector,+  ghc-options: -Wall -Wno-name-shadowing
+ src/MiniLight.hs view
@@ -0,0 +1,163 @@+{-| 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,+  LoopState (..),+  runMainloop,+) where++import Control.Concurrent (threadDelay)+import Control.Monad.Catch+import Control.Monad.Reader+import qualified Data.Aeson as Aeson+import Data.Hashable (Hashable(..))+import Data.Foldable (foldlM)+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Vector.Mutable as VM+import Graphics.Text.TrueType+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+  :: (HasLightEnv env, MonadIO m, MonadMask m)+  => (LightEnv -> env)  -- ^ construct @env@ value with initial 'LightEnv'+  -> LightT env m a+  -> m a+runLightT init prog = withSDL $ withWindow $ \window -> do+  renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer+  fc       <- loadFontCache+  runReaderT (runLightT' prog) $ init $ 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.+defConfig :: LoopConfig+defConfig = LoopConfig+  { watchKeys            = Nothing+  , appConfigFile        = Nothing+  , componentResolver    = defResolver+  , additionalComponents = []+  }++-- | LoopState value would be passed to user side in a mainloop.+data LoopState = LoopState {+  keyStates :: HM.HashMap SDL.Scancode Int,  -- ^ Contains the number of frames that a specific keys are continuously pressing.+  events :: [SDL.Event],  -- ^ Occurred events since the last frame.+  components :: VM.IOVector Component  -- ^ Current components managed in a mainloop. Be careful to modify a component destructively.+}++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++-- | 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, MonadIO m, MonadMask m)+  => LoopConfig  -- ^ loop config+  -> s  -- ^ initial state+  -> (LoopState -> s -> LightT env m s)  -- ^ a function called in every loop+  -> LightT env m ()+runMainloop conf initial loop = do+  components <-+    liftMiniLight $ fromList . (++ additionalComponents conf) =<< maybe+      (return [])+      (flip loadAppConfig (componentResolver conf))+      (appConfigFile conf)++  go (LoopState {keyStates = HM.empty, events = [], 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' <- update comp+      liftIO $ VM.write (components loopState) i comp'++    s' <- loop loopState s++    liftIO $ SDL.present renderer++    liftIO $ threadDelay (100000 `div` 60)+    events <- SDL.pollEvents+    keys   <- SDL.getKeyboardState++    forM_ [0 .. VM.length (components loopState) - 1] $ \i -> do+      comp  <- liftIO $ VM.read (components loopState) i+      comp' <- foldlM (\comp ev -> onSignal (RawEvent 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, events = events }+    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
+ src/MiniLight/Component.hs view
@@ -0,0 +1,82 @@+{-| The package provides configuration loader and pre-defined resolver.++An configuration example:++@+_vars:+  window:+    width: 800+    height: 600+app:+  - name: message-layer+    properties:+      window:+        image: resources/window-base.png+        position:+          x: 0+          y: ${${var:window.height} - ${ref:..size.height}}+        size:+          width: ${var:window.width}+          height: 150+@++== Syntax++=== @_vars@++You can define a new variable. Use object syntax under the @_vars@ field.++The variables can be referenced in all siblings and under their siblings to the @_vars@, in the variable syntax @${var:_path_}@.++=== Expr++In each field, you can specify an expression defined in the loader.++- @${}@: enclose the expr by @${}@, to tell the parsers that the field is an expr not a plain string.+- @${ref:_path_}@: specify any path to refer any other value. The path resolution is performed once, not recursively resolved. @_path_@ consists of field names splitted by a period. Use double dots @..@ for a parent.+- @${var:_path_}@: specify any path to value defined at the field. @_path_@ consists of field names splitted by a period.+- arithmetic operator: addition, subtraction, multiplication and division (@+,-,*,/@) can also be used in @${}@.++-}+module MiniLight.Component (+  module MiniLight.Component.Types,+  loadAppConfig,++  Resolver,+  defResolver+) where++import qualified Data.Aeson as Aeson+import qualified Data.Text as T+import MiniLight.Light+import MiniLight.Component.Types+import MiniLight.Component.Loader+import qualified MiniLight.Component.AnimationLayer as AnimationLayer+import qualified MiniLight.Component.Button as Button+import qualified MiniLight.Component.Layer as Layer+import qualified MiniLight.Component.MessageEngine as MessageEngine+import qualified MiniLight.Component.MessageLayer as MessageLayer++foldResult :: (String -> b) -> (a -> b) -> Aeson.Result a -> b+foldResult f g r = case r of+  Aeson.Error   err -> f err+  Aeson.Success a   -> g a++type Resolver = T.Text -> Aeson.Value -> MiniLight Component++-- | Pre-defined resolver supports all components in this library.+defResolver :: Resolver+defResolver name props = case name of+  "animation-layer" -> newComponent+    =<< AnimationLayer.new (foldResult error id $ Aeson.fromJSON props)+  "button" ->+    newComponent =<< Button.new (foldResult error id $ Aeson.fromJSON props)+  "layer" ->+    newComponent =<< Layer.new (foldResult error id $ Aeson.fromJSON props)+  "message-engine" -> newComponent+    =<< MessageEngine.new (foldResult error id $ Aeson.fromJSON props)+  "message-layer" -> newComponent+    =<< MessageLayer.new (foldResult error id $ Aeson.fromJSON props)+  "tiled-layer" -> newComponent+    =<< Layer.newNineTile (foldResult error id $ Aeson.fromJSON props)+  _ -> error $ T.unpack $ "Component not defined: `" <> name <> "`"
+ src/MiniLight/Component/AnimationLayer.hs view
@@ -0,0 +1,56 @@+module MiniLight.Component.AnimationLayer where++import Control.Monad.State+import Data.Aeson+import Linear+import Lens.Micro+import MiniLight.Figure+import MiniLight.Light+import qualified MiniLight.Component.Layer as Layer+import MiniLight.Component.Types+import qualified SDL+import qualified SDL.Vect as Vect++data AnimationLayer = AnimationLayer {+  layer :: Layer.Layer,+  counter :: Int,+  tileSize :: Vect.V2 Int,+  scaler :: Int,+  config :: Config+}++instance ComponentUnit AnimationLayer where+  update = execStateT $ do+    modify $ \c -> c { counter = (counter c + 1) }+    modify $ \c -> c { counter = if counter c >= (division (config c) ^._x * division (config c) ^. _y) * scaler c then 0 else counter c }++  figures comp = do+    let iv = V2 ((counter comp `div` scaler comp) `mod` division (config comp) ^. _x) ((counter comp `div` scaler comp) `div` division (config comp) ^. _x)+    return [+      clip (SDL.Rectangle (SDL.P (tileSize comp * iv)) (tileSize comp)) $ Layer.layer $ layer comp+      ]++data Config = Config {+  layerConf :: Layer.Config,+  division :: Vect.V2 Int+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    conf <- parseJSON (Object v)+    division <- (\v -> Vect.V2 <$> v .: "x" <*> v .: "y") =<< v .: "division"++    return $ Config conf division++new :: Config -> MiniLight AnimationLayer+new conf = do+  layer <- Layer.new (layerConf conf)+  let size = getFigureSize (Layer.layer layer)++  return $ AnimationLayer+    { layer    = layer+    , counter  = 0+    , tileSize = div <$> size <*> division conf+    , scaler   = 25+    , config   = conf+    }
+ src/MiniLight/Component/Button.hs view
@@ -0,0 +1,65 @@+module MiniLight.Component.Button where++import Control.Monad.IO.Class+import Data.Aeson+import qualified Data.Text as T+import Data.Word (Word8)+import MiniLight.Component.Types+import MiniLight.Event+import MiniLight.Figure+import MiniLight.Light+import qualified SDL+import qualified SDL.Font+import qualified SDL.Vect as Vect++data Button = Button {+  font :: SDL.Font.Font,+  config :: Config+}++instance ComponentUnit Button where+  update = return++  figures comp = do+    textTexture <- liftMiniLight $ text (font comp) (color (config comp)) $ label (config comp)+    base <- liftMiniLight $ rectangleFilled (Vect.V4 200 200 200 255) (getFigureSize textTexture)++    return [+      base,+      textTexture+      ]++  useCache _ _ = True++  onSignal (RawEvent (SDL.Event _ (SDL.MouseButtonEvent (SDL.MouseButtonEventData _ SDL.Released _ _ _ _)))) comp = do+    liftIO $ print "hey!"+    return comp+  onSignal _ comp = return comp++data Config = Config {+  size :: Vect.V2 Int,+  label :: T.Text,+  color :: Vect.V4 Word8,+  fontConf :: FontDescriptor,+  fontSize :: Int+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    size <- withObject "font" (\v -> Vect.V2 <$> v .: "width" <*> v .: "height") =<< v .: "size"+    label <- v .: "label"+    [r,g,b,a] <- v .:? "color" .!= [255, 255, 255, 255]+    (fontConf, fontSize) <- (v .: "font" >>=) $ 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 label (Vect.V4 r g b a) fontConf fontSize++new :: Config -> MiniLight Button+new conf = do+  font <- loadFont (fontConf conf) (fontSize conf)+  return $ Button {font = font, config = conf}
+ src/MiniLight/Component/Layer.hs view
@@ -0,0 +1,85 @@+module MiniLight.Component.Layer where++import Control.Monad+import Data.Aeson+import Lens.Micro+import Lens.Micro.Mtl+import Linear+import MiniLight.Component.Types+import MiniLight.Light+import MiniLight.Figure+import qualified SDL+import qualified SDL.Vect as Vect++data Layer = Layer {+  layer :: Figure+}++instance ComponentUnit Layer where+  figures comp = return [layer comp]++data Config = Config {+  image :: FilePath,+  size :: Vect.V2 Int,+  position :: Vect.V2 Int+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    image <- v .: "image"+    size <- withObject "size" (\v -> Vect.V2 <$> v .: "width" <*> v .: "height") =<< v .: "size"++    positionMaybe <- v .:? "position"+    position <- maybe (return 0) (withObject "position" (\v -> Vect.V2 <$> v .: "x" <*> v .: "y")) positionMaybe++    return $ Config image size position++new :: Config -> MiniLight Layer+new conf = do+  pic <- picture (image conf)+  return $ Layer {layer = pic}++newNineTile :: Config -> MiniLight Layer+newNineTile conf = do+  pic <- picture $ image conf+  let siz     = fmap toEnum $ size conf+  let tex     = texture pic+  let texSize = fmap toEnum $ getFigureSize pic++  tinfo    <- SDL.queryTexture tex+  renderer <- view rendererL++  target   <- SDL.createTexture renderer+                                (SDL.texturePixelFormat tinfo)+                                SDL.TextureAccessTarget+                                siz+  SDL.rendererRenderTarget renderer SDL.$= Just target+  SDL.textureBlendMode target SDL.$= SDL.BlendAlphaBlend++  let tileSize = fmap (`div` 3) texSize++  forM_ [0 .. 2] $ \ix -> forM_ [0 .. 2] $ \iy -> do+    let targetSize = V2+          (if ix == 1 then siz ^. _x - 2 * tileSize ^. _x else tileSize ^. _x)+          (if iy == 1 then siz ^. _y - 2 * tileSize ^. _y else tileSize ^. _y)+    let targetLoc = V2+          ( if ix == 0+            then 0+            else if ix == 1 then tileSize ^. _x else siz ^. _x - tileSize ^. _x+          )+          ( if iy == 0+            then 0+            else if iy == 1 then tileSize ^. _y else siz ^. _y - tileSize ^. _y+          )++    SDL.copy+      renderer+      tex+      (Just $ SDL.Rectangle (SDL.P (tileSize * Vect.V2 ix iy)) tileSize)+      (Just $ SDL.Rectangle (SDL.P targetLoc) targetSize)++  SDL.rendererRenderTarget renderer SDL.$= Nothing++  tex <- fromTexture target+  return $ Layer {layer = tex}+
+ src/MiniLight/Component/Loader.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+module MiniLight.Component.Loader where++import Control.Applicative+import Control.Monad.IO.Class+import Data.Aeson hiding (Result)+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as V+import Data.Scientific (Scientific, fromFloatDigits)+import Data.Yaml (decodeFileEither)+import GHC.Generics+import MiniLight.Light+import MiniLight.Component.Types+import Text.Trifecta++data ComponentConfig = ComponentConfig {+  name :: T.Text,+  properties :: Value+} deriving Generic++instance FromJSON ComponentConfig++data AppConfig = AppConfig {+  app :: [ComponentConfig]+} deriving Generic++instance FromJSON AppConfig++-- | Load an config file and construct components.+loadAppConfig+  :: (HasLightEnv env, MonadIO m)+  => FilePath  -- ^ Filepath to the yaml file.+  -> (T.Text -> Value -> LightT env m Component)  -- ^ Specify any resolver.+  -> LightT env m [Component]+loadAppConfig path mapper = do+  conf <- liftIO $ (\(Data.Aeson.Success a) -> a) . fromJSON . resolve . either (error . show) id <$> decodeFileEither path+  mapM (\conf -> mapper (name conf) (properties conf)) (app conf)++data Expr+  = None+  | Ref T.Text  -- ^ reference syntax: ${ref:...}+  | Var T.Text  -- ^ variable syntax: ${var:...}+  | Op T.Text Expr Expr  -- ^ expr operator: +, -, *, /+  | Constant Value  -- ^ constants (string or number or null)+  deriving (Eq, Show)++parser :: Parser Expr+parser = try reference <|> try variable <|> (char '$' *> braces (number <|> expr))+ where+  expr      = chainl expr1 op1 None+  expr1     = chainl expr2 op2 None+  expr2     = parens expr <|> try reference <|> try variable <|> try number++  -- low precedence infixl operator group+  op1       = Op "+" <$ textSymbol "+" <|> Op "-" <$ textSymbol "-"++  -- high precedence infixl operator group+  op2       = Op "*" <$ textSymbol "*" <|> Op "/" <$ textSymbol "/"++  reference = do+    char '$'+    braces $ text "ref:" *> (fmap (Ref . T.pack) (many (letter <|> oneOf ".")))+  variable = do+    char '$'+    braces $ text "var:" *> (fmap (Var . T.pack) (many (letter <|> oneOf ".")))+  number = fmap (Constant . Number . either fromIntegral fromFloatDigits)+                integerOrDouble++data Context = Context {+  path :: V.Vector (Either Int T.Text),+  variables :: Object,+  target :: Value+}++getAt :: Value -> [Either Int T.Text] -> Value+getAt = go+ where+  go value        [] = value+  go (Object obj) (Right key:ps) | key `HM.member` obj = go (obj HM.! key) ps+  go (Array  arr) (Left  i  :ps) | 0 <= i && i < V.length arr = go (arr V.! i) ps+  go v (p:_) =+    error+      $  "TypeError: path `"+      <> show p+      <> "` is missing in `"+      <> show v+      <> "`"++normalize+  :: V.Vector (Either Int T.Text) -> [Either Int T.Text] -> [Either Int T.Text]+normalize path1 ts = V.toList path1' ++ dropWhile (\v -> v == Right "") ts+ where+  depth  = length $ takeWhile (\v -> v == Right "") ts+  path1' = V.take (V.length path1 - depth - 1) path1++pattern Arithmetic :: T.Text -> Scientific -> Scientific -> Expr+pattern Arithmetic op n1 n2 =+  Op op (Constant (Number n1)) (Constant (Number n2))++eval :: Context -> Expr -> Value+eval ctx = go+ where+  go None = ""+  go (Ref path') =+    getAt (target ctx) (normalize (path ctx) (convertPath path'))+  go (Var path') =+    getAt (Object (variables ctx)) (normalize V.empty (convertPath path'))+  go (binds -> Arithmetic "+" n1 n2) = Number (n1+n2)+  go (binds -> Arithmetic "-" n1 n2) = Number (n1-n2)+  go (binds -> Arithmetic "*" n1 n2) = Number (n1*n2)+  go (binds -> Arithmetic "/" n1 n2) = Number (n1/n2)+  go expr = error $ "Illegal expression: " ++ show expr++  binds (Op op e1 e2) = Op op (Constant (eval ctx e1)) (Constant (eval ctx e2))+  binds _ = undefined++convertPath :: T.Text -> [Either Int T.Text]+convertPath+  = map+      ( \t ->+        foldResult (\_ -> Right t) (Left . fromIntegral) $ parseText index t+      )+    . T.splitOn "."+    . (\t -> if T.length t > 0 && T.head t == '.' then T.tail t else t)+  where index = char '[' *> natural <* char ']'++convert :: Context -> T.Text -> Value+convert ctx t = foldResult (\_ -> String t) (eval ctx) $ parseText parser t++parseText :: Parser a -> T.Text -> Result a+parseText parser = parseByteString parser mempty . TE.encodeUtf8++resolve :: Value -> Value+resolve = \value -> go (Context V.empty HM.empty value) value+ where+  go ctx (Object obj)+    | "_vars" `HM.member` obj+    = let vars = obj HM.! "_vars"+      in  go+            ( ctx+              { variables = HM.union ((\(Object o) -> o) $ vars) (variables ctx)+              }+            )+            (Object (HM.delete "_vars" obj))+    | otherwise+    = Object $ HM.mapWithKey+      (\key -> go (ctx { path = V.snoc (path ctx) (Right key) }))+      obj+  go ctx (Array arr) =+    Array $ V.imap (\i -> go (ctx { path = V.snoc (path ctx) (Left i) })) arr+  go ctx (String t) = convert ctx t+  go _ (Number n) = Number n+  go _ (Bool   b) = Bool b+  go _ Null       = Null
+ src/MiniLight/Component/MessageEngine.hs view
@@ -0,0 +1,80 @@+module MiniLight.Component.MessageEngine where++import Control.Monad.State+import Data.Aeson+import qualified Data.Text as T+import Data.Word (Word8)+import Lens.Micro.Mtl+import MiniLight.Component.Types+import MiniLight.Figure+import MiniLight.Light+import qualified SDL+import qualified SDL.Font+import qualified SDL.Vect as Vect++data MessageEngine = MessageEngine {+  font :: SDL.Font.Font,+  counter :: Int,+  rendered :: Int,+  textTexture :: Figure,+  finished :: Bool,+  config :: Config+}++instance ComponentUnit MessageEngine where+  update = execStateT $ do+    comp <- get++    unless (finished comp) $ do+      when (counter comp `mod` 10 == 0) $ do+        id %= (\c -> c { rendered = rendered c + 1 })++        comp <- get+        when (rendered comp == T.length (messages (config comp))) $ do+          id %= (\c -> c { finished = True })++      id %= (\c -> c { counter = counter c + 1 })++  figures comp = do+    (w, h) <- SDL.Font.size (font comp) (T.take (rendered comp) $ messages (config comp))++    return [+      clip (SDL.Rectangle 0 (Vect.V2 w h)) $ textTexture comp+      ]++data Config = Config {+  messages :: T.Text,+  static :: Bool,+  color :: Vect.V4 Word8,+  fontConf :: FontDescriptor,+  fontSize :: Int+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    messages <- v .: "messages"+    static <- v .:? "static" .!= False+    [r,g,b,a] <- v .:? "color" .!= [255, 255, 255, 255]+    (fontConf, size) <- (v .: "font" >>=) $ 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 messages static (Vect.V4 r g b a) fontConf size++new :: Config -> MiniLight MessageEngine+new conf = do+  font        <- loadFont (fontConf conf) (fontSize conf)+  textTexture <- text font (color conf) $ messages conf++  return $ MessageEngine+    { font        = font+    , counter     = 0+    , rendered    = if static conf then T.length (messages conf) else 0+    , textTexture = textTexture+    , finished    = static conf+    , config      = conf+    }
+ src/MiniLight/Component/MessageLayer.hs view
@@ -0,0 +1,77 @@+module MiniLight.Component.MessageLayer where++import Control.Monad.State+import Data.Aeson+import Lens.Micro+import Lens.Micro.Mtl+import Linear+import MiniLight.Component.Types+import qualified MiniLight.Component.Layer as CLayer+import qualified MiniLight.Component.AnimationLayer as CAnim+import qualified MiniLight.Component.MessageEngine as CME+import MiniLight.Figure+import MiniLight.Light+import qualified SDL.Vect as Vect++data MessageLayer = MessageLayer {+  messageEngine :: CME.MessageEngine,+  layer :: CLayer.Layer,+  cursor :: CAnim.AnimationLayer,+  config :: Config+}++engineL :: Lens' MessageLayer CME.MessageEngine+engineL = lens messageEngine (\s a -> s { messageEngine = a })++cursorL :: Lens' MessageLayer CAnim.AnimationLayer+cursorL = lens cursor (\s a -> s { cursor = a })++instance ComponentUnit MessageLayer where+  update = execStateT $ do+    zoom engineL $ do+      c <- use id+      id <~ lift (update c)++    zoom cursorL $ do+      c <- use id+      id <~ lift (update c)++  figures comp = do+    baseLayer <- figures $ layer comp+    cursorLayer <- figures $ cursor comp+    textLayer <- figures $ messageEngine comp++    let cursorSize = div <$> CAnim.tileSize (cursor comp) <*> CAnim.division (CAnim.config (cursor comp))+    let windowSize = CLayer.size $ window $ config comp++    return+      $ map (translate (CLayer.position (window (config comp)))) $ baseLayer+      ++ map (translate (Vect.V2 20 10)) textLayer+      ++ map (translate (Vect.V2 ((windowSize ^. _x - cursorSize ^. _x) `div` 2) (windowSize ^. _y - cursorSize ^. _y))) cursorLayer++data Config = Config {+  engine :: CME.Config,+  window :: CLayer.Config,+  next :: CAnim.Config+}++instance FromJSON Config where+  parseJSON = withObject "config" $ \v -> do+    layerConf <- parseJSON =<< v .: "window"+    nextConf <- parseJSON =<< v .: "next"+    messageEngineConf <- parseJSON =<< v .: "engine"++    return $ Config messageEngineConf layerConf nextConf++new :: Config -> MiniLight MessageLayer+new conf = do+  engine <- CME.new (engine conf)+  layer  <- CLayer.newNineTile (window conf)+  cursor <- CAnim.new (next conf)++  return $ MessageLayer+    { messageEngine = engine+    , layer         = layer+    , cursor        = cursor+    , config        = conf+    }
+ src/MiniLight/Component/Types.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE ExistentialQuantification #-}+module MiniLight.Component.Types (+  ComponentUnit(..),+  Component,+  newComponent,+  getComponentSize,+  propagate,+) where++import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.IORef+import MiniLight.Light+import MiniLight.Event+import MiniLight.Figure+import qualified SDL++-- | CompoonentUnit typeclass provides a way to define a new component.+-- Any 'ComponentUnit' instance can be embedded into 'Component' type.+class ComponentUnit c where+  -- | Updating a model.+  update :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m c+  update = return++  -- | Descirbes a view. The figures here would be cached. See also 'useCache' for the cache configuration.+  figures :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m [Figure]++  -- | Drawing a figures.+  draw :: (HasLightEnv env, MonadIO m, MonadMask m) => c -> LightT env m ()+  draw comp = liftMiniLight . renders =<< figures comp+  {-# INLINE draw #-}++  -- | Return @True@ if a cache stored in the previous frame should be used.+  useCache+    :: c  -- ^ A model value in the previous frame+    -> c  -- ^ A model value in the current frame+    -> Bool+  useCache _ _ = False++  -- | Event handlers+  onSignal :: (HasLightEnv env, MonadIO m, MonadMask m) => Event -> c -> LightT env m c+  onSignal _ = return++-- | A wrapper for 'ComponentUnit' instances.+data Component = forall c. ComponentUnit c => Component {+  component :: c,+  prev :: c,+  cache :: IORef [Figure]+}++-- | Create a new component.+newComponent+  :: (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m)+  => c+  -> LightT env m Component+newComponent c = do+  figs <- figures c+  ref  <- liftIO $ newIORef figs+  return $ Component {component = c, prev = c, cache = ref}++-- | Get the size of a component.+getComponentSize+  :: (ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m)+  => c+  -> LightT env m (SDL.Rectangle Int)+getComponentSize comp = do+  figs <- figures comp+  return $ foldl union (SDL.Rectangle (SDL.P 0) 0) $ map targetArea figs++-- | Clear the previous model cache and reflect the current model.+propagate :: Component -> Component+propagate (Component comp _ cache) = Component comp comp cache++instance ComponentUnit Component where+  update (Component comp prev cache) = do+    comp' <- update comp+    return $ Component comp' prev cache++  figures (Component comp _ _) = figures comp++  draw (Component comp prev ref) = liftMiniLight $ do+    if useCache prev comp+      then renders =<< liftIO (readIORef ref)+      else do+        figs <- liftIO (readIORef ref)+        mapM_ freeFigure figs++        figs <- figures comp+        renders figs+        liftIO $ writeIORef ref figs++  onSignal ev (Component comp prev cache) = fmap (\comp' -> Component comp' prev cache) $ onSignal ev comp
+ src/MiniLight/Event.hs view
@@ -0,0 +1,12 @@+module MiniLight.Event (+  Event(..),+) where++import qualified SDL+import qualified Data.Text as T+import Language.Haskell.TH (Name)++data Event+  = Never+  | ComponentEvent Name T.Text+  | RawEvent SDL.Event
+ src/MiniLight/Figure.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+-- | This module provides many convenient operations for textures.+module MiniLight.Figure where++import Control.Monad.Catch+import Control.Monad.IO.Class+import qualified Data.Text as T+import Data.Word (Word8)+import Lens.Micro+import Lens.Micro.Mtl+import Linear (_x, _y)+import MiniLight.Light+import qualified SDL+import qualified SDL.Font+import qualified SDL.Image+import qualified SDL.Primitive as Gfx+import qualified SDL.Vect as Vect++-- | Lens for the center of a rectangle.+centerL :: Lens' (SDL.Rectangle a) (Vect.V2 a)+centerL = lens+  (\(SDL.Rectangle (SDL.P center) _) -> center)+  (\(SDL.Rectangle _ size) center' -> SDL.Rectangle (SDL.P center') size)++-- | Lens for the size of a rectangle.+sizeL :: Lens' (SDL.Rectangle a) (Vect.V2 a)+sizeL = lens (\(SDL.Rectangle _ size) -> size)+             (\(SDL.Rectangle center _) size' -> SDL.Rectangle center size')++-- | Figure type carries a texture, sizing information and rotation information.+data Figure = Figure {+  texture :: SDL.Texture,+  sourceArea :: SDL.Rectangle Int,+  targetArea :: SDL.Rectangle Int,+  rotation :: Double+}++getFigureSize :: Figure -> Vect.V2 Int+getFigureSize fig = (\(SDL.Rectangle _ size) -> size) $ targetArea fig+{-# INLINE getFigureSize #-}++freeFigure :: MonadIO m => Figure -> m ()+freeFigure = SDL.destroyTexture . texture+{-# INLINE freeFigure #-}++union :: SDL.Rectangle Int -> SDL.Rectangle Int -> SDL.Rectangle Int+union x@(SDL.Rectangle (SDL.P c1) s1) y@(SDL.Rectangle (SDL.P c2) s2)+  | c1 <= c2 = SDL.Rectangle (SDL.P (fmap (2 *) c1 - s1 + fmap (2 *) c2 + s2))+                             (c2 - c1 + fmap (`div` 2) (s1 + s2))+  | otherwise = union y x++-- | Render a figure.+render :: (HasLightEnv env, MonadIO m, MonadMask m) => Figure -> LightT env m ()+render fig = do+  renderer <- view rendererL++  SDL.copyEx renderer+             (texture fig)+             (Just (fmap toEnum $ sourceArea fig))+             (Just (fmap toEnum $ targetArea fig))+             (realToFrac (rotation fig) * 180 / pi)+             Nothing+             (Vect.V2 False False)+{-# INLINE render #-}++-- | Render figures.+renders+  :: (HasLightEnv env, MonadIO m, MonadMask m) => [Figure] -> LightT env m ()+renders = mapM_ render+{-# INLINE renders #-}++withBlendedText+  :: (MonadIO m, MonadMask m)+  => SDL.Font.Font+  -> T.Text+  -> SDL.Font.Color+  -> (SDL.Surface -> m a)+  -> m a+withBlendedText font text color =+  bracket (SDL.Font.blended font color text) SDL.freeSurface+{-# INLINE withBlendedText #-}++-- | Rendering typeclass provides basic operations for figures.+class Rendering r m | r -> m where+  -- | Change the place to be rendered.+  translate :: Vect.V2 Int -> r -> r++  -- | Specify some area and clip the figure into the region.+  clip :: SDL.Rectangle Int -> r -> r++  -- | Rotate a figure.+  rotate :: Double -> r -> r++  -- | Create a text texture. __Be careful__: this is a slow operation, use cache as long as you can.+  text :: SDL.Font.Font -> Vect.V4 Word8 -> T.Text -> m r++  -- | Create a texture from a png file. __Be careful__: this is a slow operation, use cache as long as you can.+  picture :: FilePath -> m r++  -- | Create a texture from a raw SDL texture.+  fromTexture :: SDL.Texture -> m r++  -- | Create an outlined rectangle. __Be careful__: this is a slow operation, use cache as long as you can.+  rectangleOutline+    :: Vect.V4 Word8  -- ^ Stroke color+    -> Vect.V2 Int  -- ^ Size+    -> m r++  -- | Create a filled texture. __Be careful__: this is a slow operation, use cache as long as you can.+  rectangleFilled+    :: Vect.V4 Word8  -- ^ Filling color+    -> Vect.V2 Int  -- ^ Size+    -> m r++  -- | Create an outlined triangle. __Be careful__: this is a slow operation, use cache as long as you can.+  triangleOutline+    :: Vect.V4 Word8  -- ^ Stroke color+    -> Vect.V2 Int  -- ^ Size+    -> m r++instance Rendering Figure MiniLight where+  translate v fig =+    let cv = fmap toEnum v in+    fig { targetArea = centerL +~ cv $ targetArea fig }+  {-# INLINE translate #-}++  -- srcArea and tgtArea should be the same size+  clip (SDL.Rectangle (SDL.P point') size') fig =+    let SDL.Rectangle (SDL.P point) _ = sourceArea fig;+        sourceArea' = (SDL.Rectangle (SDL.P $ point + fmap toEnum point') (fmap toEnum size'));+        SDL.Rectangle p _ = targetArea fig;+        targetArea' = (SDL.Rectangle p (fmap toEnum size'))+    in fig { sourceArea = sourceArea', targetArea = targetArea' }+  {-# INLINE clip #-}++  rotate ang fig = fig { rotation = ang }+  {-# INLINE rotate #-}++  text font color txt = do+    renderer <- view rendererL++    withBlendedText font txt color $ \surf -> do+      texture <- SDL.createTextureFromSurface renderer surf+      tinfo <- SDL.queryTexture texture+      let rect = fmap fromEnum $ SDL.Rectangle (SDL.P 0) (Vect.V2 (SDL.textureWidth tinfo) (SDL.textureHeight tinfo))++      return $ Figure texture rect rect 0+  {-# INLINE text #-}++  picture filepath = do+    renderer <- view rendererL++    texture <- SDL.Image.loadTexture renderer filepath+    tinfo <- SDL.queryTexture texture+    let rect = fmap fromEnum $ SDL.Rectangle (SDL.P 0) (Vect.V2 (SDL.textureWidth tinfo) (SDL.textureHeight tinfo))++    return $ Figure texture rect rect 0+  {-# INLINE picture #-}++  fromTexture tex = do+    tinfo <- SDL.queryTexture tex+    let size = fmap fromEnum $ Vect.V2 (SDL.textureWidth tinfo) (SDL.textureHeight tinfo)++    return $ Figure tex (SDL.Rectangle 0 size) (SDL.Rectangle 0 size) 0+  {-# INLINE fromTexture #-}++  rectangleOutline color size = do+    rend <- view rendererL+    tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size)+    SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend++    bracket (SDL.get (SDL.rendererRenderTarget rend)) (\target -> SDL.rendererRenderTarget rend SDL.$= target) $ \_ -> do+      SDL.rendererRenderTarget rend SDL.$= Just tex+      SDL.rendererDrawColor rend SDL.$= color+      SDL.drawRect rend (Just $ SDL.Rectangle 0 (fmap toEnum size))++    return $ Figure tex (SDL.Rectangle 0 size) (SDL.Rectangle 0 size) 0+  {-# INLINE rectangleOutline #-}++  rectangleFilled color size = do+    rend <- view rendererL+    tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size)+    SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend++    bracket (SDL.get (SDL.rendererRenderTarget rend)) (\target -> SDL.rendererRenderTarget rend SDL.$= target) $ \_ -> do+      SDL.rendererRenderTarget rend SDL.$= Just tex+      SDL.rendererDrawColor rend SDL.$= color+      SDL.fillRect rend (Just $ SDL.Rectangle 0 (fmap toEnum size))++    return $ Figure tex (SDL.Rectangle 0 size) (SDL.Rectangle 0 size) 0+  {-# INLINE rectangleFilled #-}++  triangleOutline color size = do+    rend <- view rendererL+    tex <- SDL.createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fmap toEnum size)+    SDL.textureBlendMode tex SDL.$= SDL.BlendAlphaBlend++    bracket (SDL.get (SDL.rendererRenderTarget rend)) (\target -> SDL.rendererRenderTarget rend SDL.$= target) $ \_ -> do+      SDL.rendererRenderTarget rend SDL.$= Just tex+      SDL.rendererDrawColor rend SDL.$= color++      let size' = fmap toEnum size+      Gfx.smoothTriangle+        rend+        (Vect.V2 (size' ^. _x `div` 2) 0)+        (Vect.V2 (size' ^. _x - 1) (size' ^. _y - 1))+        (Vect.V2 0 (size' ^. _y - 1))+        color++    return $ Figure tex (SDL.Rectangle 0 size) (SDL.Rectangle 0 size) 0+  {-# INLINE triangleOutline #-}
+ src/MiniLight/Light.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RoleAnnotations #-}+module MiniLight.Light (+  MonadIO(..),++  HasLightEnv (..),+  LightT (..),+  LightEnv (..),+  MiniLight,+  liftMiniLight,+  envLightT,+  mapLightT,++  FontDescriptor(..),+  FontStyle(..),+  loadFontCache,+  loadFont,+  withFont+) where++import Control.Monad.IO.Class+import Control.Monad.Catch+import Control.Monad.Reader+import Data.Hashable (Hashable(..))+import qualified Data.HashMap.Strict as HM+import Graphics.Text.TrueType+import Lens.Micro+import Lens.Micro.Mtl+import qualified SDL+import qualified SDL.Font++type FontMap = HM.HashMap FontDescriptor FilePath++instance Hashable FontDescriptor where+  hashWithSalt n fd = let style = _descriptorStyle fd in hashWithSalt n (_descriptorFamilyName fd, _fontStyleBold style, _fontStyleItalic style)++class HasLightEnv env where+  rendererL :: Lens' env SDL.Renderer+  fontCacheL :: Lens' env FontMap++newtype LightT env m a = LightT { runLightT' :: ReaderT env m a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadMask, MonadCatch)++instance Monad m => MonadReader env (LightT env m) where+  ask = LightT ask+  local f = LightT . local f . runLightT'++data LightEnv = LightEnv+  { renderer :: SDL.Renderer+  , fontCache :: FontMap+  }++instance HasLightEnv LightEnv where+  rendererL = lens renderer (\env r -> env { renderer = r })+  fontCacheL = lens fontCache (\env r -> env { fontCache = r })++type MiniLight = LightT LightEnv IO++liftMiniLight :: (HasLightEnv env, MonadIO m) => MiniLight a -> LightT env m a+liftMiniLight m = do+  renderer  <- view rendererL+  fontCache <- view fontCacheL++  LightT $ ReaderT $ \_ -> liftIO $ runReaderT+    (runLightT' m)+    (LightEnv {renderer = renderer, fontCache = fontCache})+{-# INLINE liftMiniLight #-}++envLightT :: (env' -> env) -> LightT env m a -> LightT env' m a+envLightT f m = LightT $ ReaderT $ runReaderT (runLightT' m) . f+{-# INLINE envLightT #-}++mapLightT :: (m a -> n a) -> LightT env m a -> LightT env n a+mapLightT f m = LightT $ ReaderT $ f . runReaderT (runLightT' m)+{-# INLINE mapLightT #-}++loadFontCache :: MonadIO m => m FontMap+loadFontCache = do+  fc <- liftIO buildCache+  return $ foldl+    ( \fm fd -> HM.insert+      fd+      (maybe (error $ "Font not found: " ++ show fd) id (findFontInCache fc fd))+      fm+    )+    HM.empty+    (enumerateFonts fc)++loadFont+  :: (HasLightEnv env, MonadIO m)+  => FontDescriptor+  -> Int+  -> LightT env m SDL.Font.Font+loadFont fd size = do+  fc <- view fontCacheL+  let path = fc HM.! fd+  SDL.Font.load path size++withFont+  :: (HasLightEnv env, MonadIO m, MonadMask m)+  => FontDescriptor+  -> Int+  -> (SDL.Font.Font -> LightT env m a)+  -> LightT env m a+withFont fd n = bracket (loadFont fd n) SDL.Font.free
+ test/Driver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}