module Control.DysFRP.Cairo(GtkEvent, mkTickerE,
drawContextOnSurface, drawContextOnDrawable,
addRefresher, addBufRefresher, addDrawingAreaRefresher,
addDrawingAreaRefresherG,
addTick,
reactiveOn, eventData,
prerenderBG,
concatContextB,
RenderContext, mkContext,
keyValE, keyNameE, modifierE, keyValModifierE, keyLeftE, keyRightE, keyUpE, keyDownE) where
import qualified Control.DysFRP.Internal as R
import Data.IORef
import Control.Applicative
import Control.Monad.Trans
import Control.Monad.Reader
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.GC
import qualified Graphics.Rendering.Cairo as C
import Foreign.Ptr
import Data.Traversable
data GtkEvent a = GtkEvent { fromGtkEvent :: Ptr a }
type RenderContext = Double -> Double -> IO (C.Render ())
zeroRenderContext = \_ _ -> return (return ())
appendRenderContext c1 c2 = \a b -> liftM2 (>>) (c1 a b) (c2 a b)
concatContext = foldr appendRenderContext zeroRenderContext
mkContext c = \_ _ -> return c
drawContextOnSurface :: C.Surface -> RenderContext -> IO ()
drawContextOnSurface srf fig = do
w <- C.imageSurfaceGetWidth srf
h <- C.imageSurfaceGetHeight srf
rnd <- fig (fromIntegral w) (fromIntegral h)
C.renderWith srf rnd
drawContextOnDrawable :: DrawableClass d => d -> RenderContext -> IO ()
drawContextOnDrawable srf fig = do
(w, h) <- drawableGetSize srf
rnd <- fig (fromIntegral w) (fromIntegral h)
renderWithDrawable srf rnd
mkTickerE :: Int -> IO (HandlerId, R.Event ())
mkTickerE k = do
(f, e) <- R.mkE
c <- timeoutAdd (f () >> return True) k
return (c, e)
addRefresher :: DrawableClass d => Int -> d -> R.Behavior RenderContext -> IO HandlerId
addRefresher k srf fig = flip timeoutAdd k $ R.runBehavior fig >>= drawContextOnDrawable srf >> return True
addBufRefresher :: DrawableClass d => Int -> d -> R.Behavior RenderContext -> IO HandlerId
addBufRefresher k srf2 fig = do
(mx, my) <- drawableGetSize srf2
srf1 <- pixmapNew (Just srf2) mx my Nothing
gc <- gcNew srf2
flip timeoutAdd k $ R.runBehavior fig >>= drawContextOnDrawable srf1 >> do
drawDrawable srf2 gc srf1 0 0 0 0 (1) (1) >> return True
addDrawingAreaRefresher k drawingarea fig = do
canvas <- widgetGetDrawWindow drawingarea
(mx, my) <- drawableGetSize canvas
srfp <- newIORef =<< pixmapNew (Just canvas) mx my Nothing
gc <- gcNew canvas
flip timeoutAdd k $ do
srf <- readIORef srfp
drawContextOnDrawable srf =<< R.runBehavior fig
drawDrawable canvas gc srf 0 0 0 0 (1) (1) >> return True
addDrawingAreaRefresherG k drawingarea fig = addDrawingAreaRefresher k drawingarea =<< R.runBehavior fig
addTick :: Int -> IO (R.Event ())
addTick k = do
(f, e) <- R.mkE
flip timeoutAdd k $ f () >> return True
return e
reactiveOn :: a -> Signal a (EventM b Bool) -> IO (ConnectId a, R.Event (GtkEvent b))
reactiveOn obj sig = do
(f, e) <- R.mkE
c <- on obj sig $ ask >>= liftIO . f . GtkEvent >> return True
return (c, e)
prerenderBG :: (Int,Int) -> RenderContext -> R.Event RenderContext -> R.BehaviorGen RenderContext
prerenderBG (w,h) fig e = R.mkBG $ liftIO $ do
pixmap <- C.createImageSurface C.FormatARGB32 w h
drawContextOnSurface pixmap fig
let io = do
C.setSourceSurface pixmap 0 0
C.rectangle 0 0 (fromIntegral w) (fromIntegral h)
C.fill
hn <- io `seq` R.mkH io $ liftIO . drawContextOnSurface pixmap
R.addHandler e hn
return $ return $ mkContext io
eventData :: EventM a b -> R.Event (GtkEvent a) -> R.Event b
eventData e = R.ioMapE $ runReaderT e . fromGtkEvent
concatContextB :: [R.Behavior RenderContext] -> R.Behavior RenderContext
concatContextB = fmap concatContext . sequenceA
keyValE :: R.Event (GtkEvent EKey) -> R.Event KeyVal
keyValE = eventData eventKeyVal
keyNameE :: R.Event (GtkEvent EKey) -> R.Event String
keyNameE = eventData eventKeyName
modifierE :: R.Event (GtkEvent EKey) -> R.Event [Modifier]
modifierE = eventData eventModifier
keyValModifierE :: R.Event (GtkEvent EKey) -> R.Event (KeyVal, [Modifier])
keyValModifierE = eventData (liftM2 (,) eventKeyVal eventModifier)
keyLeftE :: R.Event (GtkEvent EKey) -> R.Event ()
keyLeftE = fmap (const ()) . R.filterE (== 0xff51) . keyValE
keyRightE :: R.Event (GtkEvent EKey) -> R.Event ()
keyRightE = fmap (const ()) . R.filterE (== 0xff53) . keyValE
keyUpE :: R.Event (GtkEvent EKey) -> R.Event ()
keyUpE = fmap (const ()) . R.filterE (== 0xff52) . keyValE
keyDownE :: R.Event (GtkEvent EKey) -> R.Event ()
keyDownE = fmap (const ()) . R.filterE (== 0xff54) . keyValE