module FRP.Helm (
Time,
EngineConfig(..),
run,
defaultConfig,
module Color,
module Graphics,
module Utilities,
module Signal,
FRP.Helm.Signal.lift
) where
import Control.Applicative
import Control.Concurrent (threadDelay)
import Control.Exception
import Control.Monad (when)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State
import Data.Bits
import Data.Foldable (forM_)
import Foreign.C.String
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import FRP.Elerea.Param hiding (Signal)
import FRP.Helm.Color as Color
import FRP.Helm.Engine
import FRP.Helm.Graphics as Graphics
import FRP.Helm.Utilities as Utilities
import FRP.Helm.Sample
import FRP.Helm.Signal as Signal hiding (lift)
import qualified FRP.Helm.Signal (lift)
import FRP.Helm.Time (Time)
import qualified FRP.Helm.Window as Window
import System.FilePath
import System.Endian
import qualified Data.Map as Map
import qualified Graphics.UI.SDL as SDL
import qualified Graphics.Rendering.Cairo as Cairo
import qualified Graphics.Rendering.Pango as Pango
type Helm a = StateT Engine Cairo.Render a
data Application = Application {
mainElement :: Element,
mainDimensions :: (Int, Int),
mainContinue :: Bool
}
data EngineConfig = EngineConfig {
windowDimensions :: (Int, Int),
windowIsFullscreen :: Bool,
windowIsResizable :: Bool,
windowTitle :: String
}
defaultConfig :: EngineConfig
defaultConfig = EngineConfig {
windowDimensions = (800, 600),
windowIsFullscreen = False,
windowIsResizable = True,
windowTitle = ""
}
startup :: EngineConfig -> IO Engine
startup (EngineConfig { .. }) = withCAString windowTitle $ \title -> do
window <- SDL.createWindow title 0 0 (fromIntegral w) (fromIntegral h) wflags
renderer <- SDL.createRenderer window (1) rflags
return Engine { window = window
, renderer = renderer
, cache = Map.empty
, continue = True
}
where
(w, h) = windowDimensions
wflags = foldl (.|.) 0 $ [SDL.windowFlagShown] ++
[SDL.windowFlagResizable | windowIsResizable] ++
[SDL.windowFlagFullscreen | windowIsFullscreen]
rflags = (.|.) SDL.rendererFlagPresentVSync SDL.rendererFlagAccelerated
run :: EngineConfig -> Signal Element -> IO ()
run config element = do engine <- startup config
run_ engine $ application <~ element
~~ Window.dimensions
~~ continue'
~~ exposed
where
application :: Element -> (Int, Int) -> Bool -> () -> Application
application e d c _ = Application e d c
run_ eng (Signal gen) = (start gen >>= run' eng) `finally` SDL.quit
exposed :: Signal ()
exposed = Signal getExposed
where
getExposed = effectful $ alloca $ \eventptr -> do
SDL.pumpEvents
status <- SDL.pollEvent eventptr
if status == 1 then do
event <- peek eventptr
case event of
SDL.WindowEvent _ _ _ e _ _ -> return $ if e == SDL.windowEventExposed
then Changed ()
else Unchanged ()
_ -> return $ Unchanged ()
else return $ Unchanged ()
quit :: Signal ()
quit = Signal getQuit
where
getQuit = effectful $ do
q <- SDL.quitRequested
return (if q then Changed () else Unchanged ())
continue' :: Signal Bool
continue' = (==0) <~ count quit
run' :: Engine -> (Engine -> IO (Sample Application)) -> IO ()
run' engine smp = when (continue engine) $ smp engine >>= renderIfChanged engine
>>= flip run' smp
renderIfChanged :: Engine -> Sample Application -> IO Engine
renderIfChanged engine event = case event of
Changed app -> if mainContinue app
then render engine (mainElement app) (mainDimensions app)
else return engine { continue = False }
Unchanged _ -> do threadDelay 1000
return engine
render :: Engine -> Element -> (Int, Int) -> IO Engine
render engine@(Engine { .. }) element (w, h) = alloca $ \pixelsptr ->
alloca $ \pitchptr -> do
format <- SDL.masksToPixelFormatEnum 32 (fromBE32 0x0000ff00)
(fromBE32 0x00ff0000) (fromBE32 0xff000000) (fromBE32 0x000000ff)
texture <- SDL.createTexture renderer format
SDL.textureAccessStreaming (fromIntegral w) (fromIntegral h)
SDL.lockTexture texture nullPtr pixelsptr pitchptr
pixels <- peek pixelsptr
pitch <- fromIntegral <$> peek pitchptr
res <- Cairo.withImageSurfaceForData (castPtr pixels)
Cairo.FormatARGB32 w h pitch $ \surface -> Cairo.renderWith surface
$ evalStateT (render' w h element) engine
SDL.unlockTexture texture
SDL.renderClear renderer
SDL.renderCopy renderer texture nullPtr nullPtr
SDL.destroyTexture texture
SDL.renderPresent renderer
return res
render' :: Int -> Int -> Element -> Helm Engine
render' w h element = do
lift $ do Cairo.setSourceRGB 0 0 0
Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h)
Cairo.fill
renderElement element
get
getSurface :: FilePath -> Helm (Cairo.Surface, Int, Int)
getSurface src = do
Engine _ _ cache _ <- get
case Map.lookup src cache of
Just surface -> do
w <- Cairo.imageSurfaceGetWidth surface
h <- Cairo.imageSurfaceGetHeight surface
return (surface, w, h)
Nothing -> do
surface <- liftIO $ Cairo.imageSurfaceCreateFromPNG src
w <- liftIO $ Cairo.imageSurfaceGetWidth surface
h <- liftIO $ Cairo.imageSurfaceGetHeight surface
modify (\engine -> engine{cache=Map.insert src surface cache})
return (surface, w, h)
renderElement :: Element -> Helm ()
renderElement (CollageElement w h center forms) = do
lift $ do Cairo.save
Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h)
Cairo.clip
forM_ center $ uncurry Cairo.translate
mapM_ renderForm forms
lift Cairo.restore
renderElement (ImageElement (sx, sy) sw sh src stretch) = do
(surface, w, h) <- getSurface (normalise src)
lift $ do Cairo.save
Cairo.translate (fromIntegral sx) (fromIntegral sy)
if stretch then
Cairo.scale (fromIntegral sw / fromIntegral w)
(fromIntegral sh / fromIntegral h)
else
Cairo.scale 1 1
Cairo.setSourceSurface surface 0 0
Cairo.translate (fromIntegral sx) (fromIntegral sy)
Cairo.rectangle 0 0 (fromIntegral sw) (fromIntegral sh)
Cairo.fill
Cairo.restore
renderElement (TextElement (Text { textColor = (Color r g b a), .. })) = do
lift Cairo.save
layout <- lift $ Pango.createLayout textUTF8
Cairo.liftIO $ Pango.layoutSetAttributes layout
[ Pango.AttrFamily { paStart = i, paEnd = j, paFamily = textTypeface }
, Pango.AttrWeight { paStart = i, paEnd = j, paWeight = mapFontWeight textWeight }
, Pango.AttrStyle { paStart = i, paEnd = j, paStyle = mapFontStyle textStyle }
, Pango.AttrSize { paStart = i, paEnd = j, paSize = textHeight }
]
Pango.PangoRectangle x y w h <- fmap snd
$ Cairo.liftIO $ Pango.layoutGetExtents layout
lift $ do Cairo.translate ((w / 2) x) ((h / 2) y)
Cairo.setSourceRGBA r g b a
Pango.showLayout layout
Cairo.restore
where
i = 0
j = length textUTF8
mapFontWeight :: FontWeight -> Pango.Weight
mapFontWeight weight = case weight of
LightWeight -> Pango.WeightLight
NormalWeight -> Pango.WeightNormal
BoldWeight -> Pango.WeightBold
mapFontStyle :: FontStyle -> Pango.FontStyle
mapFontStyle style = case style of
NormalStyle -> Pango.StyleNormal
ObliqueStyle -> Pango.StyleOblique
ItalicStyle -> Pango.StyleItalic
withTransform :: Double -> Double -> Double -> Double -> Helm () -> Helm ()
withTransform s t x y f = do
lift $ Cairo.save >> Cairo.scale s s >> Cairo.translate x y >> Cairo.rotate t
f
lift Cairo.restore
setLineCap :: LineCap -> Cairo.Render ()
setLineCap cap = case cap of
FlatCap -> Cairo.setLineCap Cairo.LineCapButt
RoundCap -> Cairo.setLineCap Cairo.LineCapRound
PaddedCap -> Cairo.setLineCap Cairo.LineCapSquare
setLineJoin :: LineJoin -> Cairo.Render ()
setLineJoin join = case join of
SmoothJoin -> Cairo.setLineJoin Cairo.LineJoinRound
SharpJoin lim -> Cairo.setLineJoin Cairo.LineJoinMiter >> Cairo.setMiterLimit lim
ClippedJoin -> Cairo.setLineJoin Cairo.LineJoinBevel
setLineStyle :: LineStyle -> Cairo.Render ()
setLineStyle (LineStyle { lineColor = Color r g b a, .. }) = do
Cairo.setSourceRGBA r g b a
setLineCap lineCap
setLineJoin lineJoin
Cairo.setLineWidth lineWidth
Cairo.setDash lineDashing lineDashOffset
Cairo.stroke
setFillStyle :: FillStyle -> Helm ()
setFillStyle (Solid (Color r g b a)) = lift $ do
Cairo.setSourceRGBA r g b a
Cairo.fill
setFillStyle (Texture src) = do
(surface, _, _) <- getSurface (normalise src)
lift $ do Cairo.setSourceSurface surface 0 0
Cairo.getSource >>= flip Cairo.patternSetExtend Cairo.ExtendRepeat
Cairo.fill
setFillStyle (Gradient (Linear (sx, sy) (ex, ey) points)) =
lift $ Cairo.withLinearPattern sx sy ex ey
$ \pattern -> setFillStyle' pattern points
setFillStyle (Gradient (Radial (sx, sy) sr (ex, ey) er points)) =
lift $ Cairo.withRadialPattern sx sy sr ex ey er
$ \pattern -> setFillStyle' pattern points
setFillStyle' :: Cairo.Pattern -> [(Double, Color)] -> Cairo.Render ()
setFillStyle' pattern points = do
Cairo.setSource pattern
mapM_ (\(o, Color r g b a) -> Cairo.patternAddColorStopRGBA pattern o r g b a) points
Cairo.fill
renderForm :: Form -> Helm ()
renderForm Form { .. } = withTransform formScale formTheta formX formY $
case formStyle of
PathForm style ~ps @ ((hx, hy) : _) -> lift $ do
Cairo.newPath
Cairo.moveTo hx hy
mapM_ (uncurry Cairo.lineTo) ps
setLineStyle style
ShapeForm style shape -> do
lift Cairo.newPath
case shape of
PolygonShape ~ps @ ((hx, hy) : _) ->
lift $ do Cairo.moveTo hx hy
mapM_ (uncurry Cairo.lineTo) ps
RectangleShape (w, h) -> lift $ Cairo.rectangle (w / 2) (h / 2) w h
ArcShape (cx, cy) a1 a2 r (sx, sy) ->
lift $ do Cairo.scale sx sy
Cairo.arc cx cy r a1 a2
Cairo.scale 1 1
either (lift . setLineStyle) setFillStyle style
ElementForm element -> renderElement element
GroupForm mayhaps forms -> do
lift $ do Cairo.save
forM_ mayhaps Cairo.setMatrix
mapM_ renderForm forms
lift Cairo.restore