diff options
author | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-08-21 19:34:16 +0200 |
---|---|---|
committer | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-08-21 19:34:16 +0200 |
commit | 42c14fa1ca9d47ae32766aaa2aa995c684b7e9cb (patch) | |
tree | 7c12e75cf89573c2d3ecb8c0c4fcc4ccbc56b24d /lib/Phi/Widget.hs | |
parent | ddca7c3ec59a5b7c62a11afe225de40edbde85ff (diff) | |
download | phi-42c14fa1ca9d47ae32766aaa2aa995c684b7e9cb.tar phi-42c14fa1ca9d47ae32766aaa2aa995c684b7e9cb.zip |
Make render function return cachable surface slices
Diffstat (limited to 'lib/Phi/Widget.hs')
-rw-r--r-- | lib/Phi/Widget.hs | 70 |
1 files changed, 39 insertions, 31 deletions
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index 2b031d9..f265c62 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -6,6 +6,7 @@ module Phi.Widget ( Display(..) , getScreenWindows , getScreens , unionArea + , SurfaceSlice(..) , Widget(..) , CompoundWidget , (<~>) @@ -20,8 +21,6 @@ import Control.Concurrent.MVar import Control.Monad import Control.Monad.IO.Class -import Data.Traversable hiding (forM) - import qualified Graphics.X11.Xlib as Xlib import Graphics.Rendering.Cairo @@ -64,20 +63,22 @@ unionArea a b = fromIntegral $ uw*uh by2 = by1 + fromIntegral bh -class (Show a, Eq a, Eq d) => Widget a d | a -> d where - initWidget :: a -> Phi -> Display -> IO d +data SurfaceSlice = SurfaceSlice !Int !Surface + +class (Show a, Eq a, Eq s) => Widget a s c | a -> s, a -> c where + initWidget :: a -> Phi -> Display -> IO s - minSize :: a -> d -> Int -> Xlib.Rectangle -> Int + minSize :: a -> s -> Int -> Xlib.Rectangle -> Int weight :: a -> Float weight _ = 0 - layout :: a -> d -> Int -> Int -> Xlib.Rectangle -> d + layout :: a -> s -> Int -> Int -> Xlib.Rectangle -> s layout _ priv _ _ _ = priv - render :: a -> d -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render () + render :: a -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> IO [(Bool, SurfaceSlice)] - handleMessage :: a -> d -> Message -> d + handleMessage :: a -> s -> Message -> s handleMessage _ priv _ = priv {-createStateRender :: Widget a d => CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface @@ -90,57 +91,64 @@ createStateRender = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do render widget state x y w h screen return surface-} -data CompoundWidget a da b db = (Widget a da, Widget b db) => CompoundWidget !a !b -deriving instance Eq (CompoundWidget a da b db) -deriving instance Show (CompoundWidget a da b db) +data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b +deriving instance Eq (CompoundWidget a sa ca b sb cb) +deriving instance Show (CompoundWidget a sa ca b sb cb) + +data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb !Int +deriving instance Eq (CompoundState a sa ca b sb cb) -data CompoundState a da b db = (Widget a da, Widget b db) => CompoundState !da !db !Int -deriving instance Eq (CompoundState a da b db) +data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundCache !ca !cb -instance Widget (CompoundWidget a da b db) (CompoundState a da b db) where + +instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) (CompoundCache a sa ca b sb cb) where initWidget (CompoundWidget a b) phi disp = liftM3 CompoundState (initWidget a phi disp) (initWidget b phi disp) (return 0) minSize (CompoundWidget a b) (CompoundState da db _) height screen = minSize a da height screen + minSize b db height screen weight (CompoundWidget a b) = weight' a + weight' b - layout c@(CompoundWidget a b) d@(CompoundState da db _) width height screen = CompoundState da' db' xb + layout c@(CompoundWidget a b) s@(CompoundState sa sb _) width height screen = CompoundState sa' sb' xb where - sizesum = minSize c d height screen + sizesum = minSize c s height screen wsum = let wsum = weight c in if wsum > 0 then wsum else 1 surplus = width - sizesum - (xb, da') = layoutWidget a da - (_, db') = layoutWidget b db + (xb, sa') = layoutWidget a sa + (_, sb') = layoutWidget b sb - layoutWidget w priv = let wWidth = floor $ (fromIntegral $ minSize w priv height screen) + (fromIntegral surplus)*(weight' w)/wsum - in (wWidth, layout w priv wWidth height screen) + layoutWidget w s = let wWidth = floor $ (fromIntegral $ minSize w s height screen) + (fromIntegral surplus)*(weight' w)/wsum + in (wWidth, layout w s wWidth height screen) - render (CompoundWidget a b) (CompoundState da db xb) x y w h screen = do - save - render a da x y xb h screen - restore - translate (fromIntegral xb) 0 - render b db (x+xb) y (w-xb) h screen + render (CompoundWidget a b) (CompoundState sa sb xb) x y w h screen = do + surfacea <- render a sa x y xb h screen + surfaceb <- render b sb (x+xb) y (w-xb) h screen + return $ surfacea ++ map (\(updated, SurfaceSlice x surface) -> (updated, SurfaceSlice (x+xb) surface)) surfaceb - handleMessage (CompoundWidget a b) (CompoundState da db xb) message = CompoundState (handleMessage a da message) (handleMessage b db message) xb + handleMessage (CompoundWidget a b) (CompoundState sa sb xb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message) xb -weight' :: (Widget a da) => a -> Float +weight' :: (Widget a sa ca) => a -> Float weight' = max 0 . weight -(<~>) :: (Widget a da, Widget b db) => a -> b -> CompoundWidget a da b db +(<~>) :: (Widget a sa ca, Widget b sb cb) => a -> b -> CompoundWidget a sa ca b sb cb a <~> b = CompoundWidget a b data Separator = Separator !Int !Float deriving (Show, Eq) -instance Widget Separator () where +instance Widget Separator () () where initWidget _ _ _ = return () minSize (Separator s _) _ _ _ = s weight (Separator _ w) = w - render _ _ _ _ _ _ _ = return () + render _ _ _ _ width height _ = do + surface <- createImageSurface FormatARGB32 width height + renderWith surface $ do + setOperator OperatorClear + paint + return [(True, SurfaceSlice 0 surface)] + separator :: Int -> Float -> Separator separator = Separator |