module FRP.Helm (
Time,
EngineConfig(..),
run,
defaultConfig,
module Color,
module Graphics,
module Utilities,
) where
import Control.Exception
import Control.Monad (when)
import Data.Foldable (forM_)
import Data.IORef
import Foreign.Ptr (castPtr)
import FRP.Elerea.Simple
import FRP.Helm.Color as Color
import FRP.Helm.Graphics as Graphics
import FRP.Helm.Utilities as Utilities
import FRP.Helm.Time (Time)
import System.FilePath
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
requestDimensions :: Int -> Int -> Bool -> IO SDL.Surface
requestDimensions w h resizable = do
mayhaps <- SDL.trySetVideoMode w h 32 $ [SDL.HWSurface, SDL.DoubleBuf] ++ flags
case mayhaps of
Just screen -> return screen
Nothing -> SDL.setVideoMode w h 32 $ SDL.SWSurface : flags
where
flags = [SDL.Resizable | resizable]
data EngineConfig = EngineConfig {
windowDimensions :: (Int, Int),
windowIsFullscreen :: Bool,
windowIsResizable :: Bool,
windowTitle :: String
}
defaultConfig :: EngineConfig
defaultConfig = EngineConfig {
windowDimensions = (800, 600),
windowIsFullscreen = False,
windowIsResizable = True,
windowTitle = ""
}
data EngineState = EngineState {
smp :: IO Element,
cache :: IORef (Map.Map FilePath Cairo.Surface)
}
newEngineState :: IO Element -> IO EngineState
newEngineState smp = do
cache <- newIORef Map.empty
return EngineState { smp = smp, cache = cache }
run :: EngineConfig -> SignalGen (Signal Element) -> IO ()
run (EngineConfig { .. }) gen = finally SDL.quit $ do
SDL.init [SDL.InitVideo, SDL.InitJoystick]
SDL.rawSetCaption (Just windowTitle) Nothing
when windowIsFullscreen $ SDL.getVideoSurface >>= SDL.toggleFullscreen
uncurry requestDimensions windowDimensions windowIsResizable
start gen >>= newEngineState >>= run'
run' :: EngineState -> IO ()
run' state = do
continue <- run''
when continue $ smp state >>= render state >> run' state
run'' :: IO Bool
run'' = do
event <- SDL.pollEvent
case event of
SDL.NoEvent -> return True
SDL.Quit -> return False
SDL.VideoResize w h -> requestDimensions w h True >> run''
_ -> run''
render :: EngineState -> Element -> IO ()
render state element = do
videoSurface <- SDL.getVideoSurface
let
w = SDL.surfaceGetWidth videoSurface
h = SDL.surfaceGetHeight videoSurface
cairoSurface <- SDL.createRGBSurface [SDL.HWSurface] w h 32 0x00ff0000 0x0000ff00 0x000000ff 0xff000000
render' state element videoSurface cairoSurface
render' :: EngineState -> Element -> SDL.Surface -> SDL.Surface -> IO ()
render' state element videoSurface cairoSurface = do
pixels <- SDL.surfaceGetPixels cairoSurface
Cairo.withImageSurfaceForData (castPtr pixels) Cairo.FormatARGB32 w h (w * 4) $ \surface ->
Cairo.renderWith surface (render'' w h state element)
SDL.blitSurface cairoSurface Nothing videoSurface Nothing
SDL.flip videoSurface
where
w = SDL.surfaceGetWidth videoSurface
h = SDL.surfaceGetHeight videoSurface
render'' :: Int -> Int -> EngineState -> Element -> Cairo.Render ()
render'' w h state element = do
Cairo.setSourceRGB 0 0 0
Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h)
Cairo.fill
renderElement state element
getSurface :: EngineState -> FilePath -> IO (Cairo.Surface, Int, Int)
getSurface (EngineState { cache }) src = do
cached <- Cairo.liftIO (readIORef cache)
case Map.lookup src cached of
Just surface -> do
w <- Cairo.imageSurfaceGetWidth surface
h <- Cairo.imageSurfaceGetHeight surface
return (surface, w, h)
Nothing -> do
surface <- Cairo.imageSurfaceCreateFromPNG src
w <- Cairo.imageSurfaceGetWidth surface
h <- Cairo.imageSurfaceGetHeight surface
writeIORef cache (Map.insert src surface cached) >> return (surface, w, h)
renderElement :: EngineState -> Element -> Cairo.Render ()
renderElement state (CollageElement w h center forms) = do
Cairo.save
Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h)
Cairo.clip
forM_ center $ uncurry Cairo.translate
mapM_ (renderForm state) forms
Cairo.restore
renderElement state (ImageElement (sx, sy) sw sh src stretch) = do
(surface, w, h) <- Cairo.liftIO $ getSurface state (normalise src)
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
Cairo.save
layout <- 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
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 -> Cairo.Render () -> Cairo.Render ()
withTransform s t x y f = Cairo.save >> Cairo.scale s s >> Cairo.translate x y >> Cairo.rotate t >> f >> 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 :: EngineState -> FillStyle -> Cairo.Render ()
setFillStyle _ (Solid (Color r g b a)) = do
Cairo.setSourceRGBA r g b a
Cairo.fill
setFillStyle state (Texture src) = do
(surface, _, _) <- Cairo.liftIO $ getSurface state (normalise src)
Cairo.setSourceSurface surface 0 0
Cairo.getSource >>= flip Cairo.patternSetExtend Cairo.ExtendRepeat
Cairo.fill
setFillStyle _ (Gradient (Linear (sx, sy) (ex, ey) points)) =
Cairo.withLinearPattern sx sy ex ey $ \pattern -> setFillStyle' pattern points
setFillStyle _ (Gradient (Radial (sx, sy) sr (ex, ey) er points)) =
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 :: EngineState -> Form -> Cairo.Render ()
renderForm state Form { .. } = withTransform formScale formTheta formX formY $
case formStyle of
PathForm style ~ps @ ((hx, hy) : _) -> do
Cairo.newPath
Cairo.moveTo hx hy
mapM_ (uncurry Cairo.lineTo) ps
setLineStyle style
ShapeForm style shape -> do
Cairo.newPath
case shape of
PolygonShape ~ps @ ((hx, hy) : _) -> do
Cairo.moveTo hx hy
mapM_ (uncurry Cairo.lineTo) ps
RectangleShape (w, h) -> Cairo.rectangle (w / 2) (h / 2) w h
ArcShape (cx, cy) a1 a2 r (sx, sy) -> do
Cairo.scale sx sy
Cairo.arc cx cy r a1 a2
Cairo.scale 1 1
either setLineStyle (setFillStyle state) style
ElementForm element -> renderElement state element
GroupForm mayhaps forms -> do
Cairo.save
forM_ mayhaps Cairo.setMatrix
mapM_ (renderForm state) forms
Cairo.restore