module FRP.Helm (
Time,
run,
radians,
degrees,
turns,
module Color,
module Graphics,
module Signal,
) 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.Signal as Signal
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
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 = finally SDL.quit $ do
SDL.init [SDL.InitVideo, SDL.InitJoystick]
requestDimensions 800 600
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 >> 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 w h centered forms) = do
Cairo.save
Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h)
Cairo.clip
when centered $ Cairo.translate (fromIntegral w / 2) (fromIntegral h / 2)
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.setSourceRGBA r g b a
Cairo.selectFontFace textTypeface textSlant textWeight
Cairo.setFontSize textHeight
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.translate x y >> Cairo.rotate t >> 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 { 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
setLineStyle style
Cairo.moveTo hx hy
mapM_ (uncurry Cairo.lineTo) ps
ShapeForm style shape -> do
case shape of
PolygonShape ~ps @ ((hx, hy) : _) -> do
Cairo.newPath
Cairo.moveTo hx hy
mapM_ (uncurry Cairo.lineTo) ps
Cairo.closePath
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