DysFRP-Cairo (empty) → 0.1

raw patch · 4 files changed

+179/−0 lines, 4 filesdep +DysFRPdep +basedep +cairosetup-changed

Dependencies added: DysFRP, base, cairo, gtk, mtl

Files

Control/DysFRP/Cairo.hs +136/−0
DysFRP-Cairo.cabal +18/−0
LICENSE +22/−0
Setup.hs +3/−0

+ Control/DysFRP/Cairo.hs view

@@ -0,0 +1,136 @@+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) <- {-fmap fixSize $-} drawableGetSize canvas+    srfp <- newIORef =<< pixmapNew (Just canvas) mx my Nothing+    gc <- gcNew canvas+{-    on drawingarea configureEvent $ do+        (x, y) <- fmap fixSize $ eventSize+        liftIO $ print (x,y)+        liftIO $ writeIORef srfp =<< pixmapNew (Just canvas) x y Nothing+        return True-}+    flip timeoutAdd k $ do+        srf <- readIORef srfp+        drawContextOnDrawable srf =<< R.runBehavior fig+        drawDrawable canvas gc srf 0 0 0 0 (-1) (-1) >> return True+{-    where+    fixSize (a, b) | fromIntegral a/(px :: Double)*py > fromIntegral b = +                                   (round $ fromIntegral b/py*px, b)+                   | otherwise   = (a, round $ fromIntegral a/px*py)-}++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+

+ DysFRP-Cairo.cabal view

@@ -0,0 +1,18 @@+Name: DysFRP-Cairo+Version: 0.1+License: BSD3+License-File: LICENSE+Author: Marek Materzok+Maintainer: Marek Materzok+Build-Type: Simple+Stability: experimental+Cabal-Version: >= 1.2+Homepage: https://github.com/tilk/DysFRP+Category: FRP+Synopsis: dysFunctional Reactive Programming on Cairo+Description: Simple Cairo bindings for DysFRP.++Library+    Build-Depends: base >= 4 && <5, cairo, gtk, mtl, DysFRP+    Exposed-modules: Control.DysFRP.Cairo+

+ LICENSE view

@@ -0,0 +1,22 @@+Copyright (c) 2012, Marek Materzok+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+

+ Setup.hs view

@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+