module FRP.Helm (
run,
radians,
degrees,
turns,
module FRP.Helm.Color,
module FRP.Helm.Graphics,
) where
import Control.Monad (void)
import Data.IORef
import Foreign.Ptr (castPtr)
import FRP.Elerea.Simple
import FRP.Helm.Color
import FRP.Helm.Graphics
import System.FilePath
import qualified Data.Map as Map
import qualified Graphics.UI.SDL as SDL
import qualified Graphics.Rendering.Cairo as Cairo
requestDimensions :: Int -> Int -> IO SDL.Surface
requestDimensions w h = do
mayhaps <- SDL.trySetVideoMode w h 32 [SDL.HWSurface, SDL.DoubleBuf, SDL.Resizable]
case mayhaps of
Just screen -> return screen
Nothing -> SDL.setVideoMode w h 32 [SDL.SWSurface, SDL.Resizable]
radians :: Double -> Double
radians n = n
degrees :: Double -> Double
degrees n = n * pi / 180
turns :: Double -> Double
turns n = 2 * pi * n
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 :: SignalGen (Signal Element) -> IO ()
run gen = SDL.init [SDL.InitVideo, SDL.InitJoystick] >> requestDimensions 800 600 >> start gen >>= newEngineState >>= run'
run' :: EngineState -> IO ()
run' state = do
continue <- run''
if continue then smp state >>= render state >> run' state else SDL.quit
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 >> run''
_ -> run''
render :: EngineState -> Element -> IO ()
render state element = SDL.getVideoSurface >>= render' state element
render' :: EngineState -> Element -> SDL.Surface -> IO ()
render' state element screen = do
pixels <- SDL.surfaceGetPixels screen
Cairo.withImageSurfaceForData (castPtr pixels) Cairo.FormatRGB24 w h (w * 4) $ \surface ->
Cairo.renderWith surface (render'' w h state element)
SDL.flip screen
where
w = SDL.surfaceGetWidth screen
h = SDL.surfaceGetHeight screen
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 _ _ forms) = void $ mapM_ (renderForm state) forms
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.setSourceRGBA r g b a
Cairo.selectFontFace fontTypeface fontSlant fontWeight
Cairo.setFontSize fontSize
Cairo.showText textUTF8
withTransform :: Double -> Double -> Double -> Double -> Cairo.Render () -> Cairo.Render ()
withTransform s t x y f = Cairo.save >> Cairo.scale s s >> Cairo.rotate t >> Cairo.translate x y >> f >> Cairo.restore
setLineCap :: LineCap -> Cairo.Render ()
setLineCap cap =
case cap of
Flat -> Cairo.setLineCap Cairo.LineCapButt
Round -> Cairo.setLineCap Cairo.LineCapRound
Padded -> Cairo.setLineCap Cairo.LineCapSquare
setLineJoin :: LineJoin -> Cairo.Render ()
setLineJoin join =
case join of
Smooth -> Cairo.setLineJoin Cairo.LineJoinRound
Sharp lim -> Cairo.setLineJoin Cairo.LineJoinMiter >> Cairo.setMiterLimit lim
Clipped -> Cairo.setLineJoin Cairo.LineJoinBevel
setLineStyle :: LineStyle -> Cairo.Render ()
setLineStyle (LineStyle { color = Color r g b a, .. }) =
Cairo.setSourceRGBA r g b a >> setLineCap cap >> setLineJoin join >>
Cairo.setLineWidth width >> Cairo.setDash dashing dashOffset >> Cairo.stroke
setFillStyle :: EngineState -> FillStyle -> Cairo.Render ()
setFillStyle _ (Solid (Color r g b a)) = 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 ->
Cairo.setSource pattern >> mapM (\(o, Color r g b a) -> Cairo.patternAddColorStopRGBA pattern o r g b a) points >> Cairo.fill
setFillStyle _ (Gradient (Radial (sx, sy) sr (ex, ey) er points)) =
Cairo.withRadialPattern sx sy sr ex ey er $ \pattern ->
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 _ (Form { style = PathForm style p, .. }) =
withTransform scalar theta x y $
void $ setLineStyle style >> Cairo.moveTo hx hy >> mapM (uncurry Cairo.lineTo) p
where
(hx, hy) = head p
renderForm state (Form { style = ShapeForm style (PolygonShape points), .. }) =
withTransform scalar theta x y $ do
Cairo.newPath >> Cairo.moveTo hx hy >> mapM (uncurry Cairo.lineTo) points >> Cairo.closePath
case style of
Left lineStyle -> setLineStyle lineStyle
Right fillStyle -> setFillStyle state fillStyle
where
(hx, hy) = head points
renderForm state (Form { style = ShapeForm style (RectangleShape (w, h)), .. }) =
withTransform scalar theta x y $ do
Cairo.rectangle 0 0 w h
case style of
Left lineStyle -> setLineStyle lineStyle
Right fillStyle -> setFillStyle state fillStyle
renderForm state (Form { style = ShapeForm style (ArcShape (cx, cy) a1 a2 r (sx, sy)), .. }) =
withTransform scalar theta x y $ do
Cairo.scale sx sy
Cairo.arc cx cy r a1 a2
Cairo.scale 1 1
case style of
Left lineStyle -> setLineStyle lineStyle
Right fillStyle -> setFillStyle state fillStyle
renderForm state (Form { style = ElementForm element, .. }) = withTransform scalar theta x y $ renderElement state element
renderForm state (Form { style = GroupForm m forms, .. }) = withTransform scalar theta x y $ void $ Cairo.setMatrix m >> mapM (renderForm state) forms