gloss-relative 0.1.0.0 → 0.1.1.0

raw patch · 11 files changed

+615/−196 lines, 11 filesdep +OpenGLdep +bytestringdep +gloss-renderingdep ~gloss-relativenew-component:exe:gloss-relative-dragPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: OpenGL, bytestring, gloss-rendering

Dependency ranges changed: gloss-relative

API changes (from Hackage documentation)

Files

• examples/Button.hs +1/−1
• examples/Drag.hs +31/−0
• gloss-relative.cabal +17/−5
• src/Graphics/Gloss/Relative/Frame.hs +2/−1
• src/Graphics/Gloss/Relative/Interface.hs +34/−18
• src/Graphics/Gloss/Relative/Internal/Cache.hs +50/−0
• src/Graphics/Gloss/Relative/Internal/Data.hs +67/−0
• src/Graphics/Gloss/Relative/Internal/Frame.hs +116/−79
• src/Graphics/Gloss/Relative/Internal/Picture.hs +30/−5
• src/Graphics/Gloss/Relative/Internal/Raster.hs +156/−0
• src/Graphics/Gloss/Relative/Internal/Window.hs +111/−87

@@ -10,7 +10,7 @@ initial = State False False  draw :: State -> Frame-draw st = Zoom 0.5 0.5 alignCenter $ bordered 10 borderc $ Label "button" $ Frames [solid c,labels]+draw st = Zoom 0.5 0.5 alignCenter $ bordered 10 borderc $ Label "button" False $ Frames [solid c,labels]     where     borderc = if pressed st then red else c     c = if selected st then grey else black

@@ -0,0 +1,31 @@+module Main where++import Graphics.Gloss.Relative+import Data.List as List++data State = State { ballPosition :: Point, ballClick :: Bool }+initial :: State+initial = State (0,0) False++draw :: State -> Frame+draw st = fixedZoom (50,50) (AbsoluteAlignment $ ballPosition st) (Label "ball" True $ solidEllipsis blue)++event :: Event -> State -> State+event e s = case e of+    EventKey { eventKey = MouseButton LeftButton, eventKeyState = kst } -> case kst of+        Down -> if isInside+            then s { ballClick = True }+            else s+        Up -> s { ballClick = False }+    EventMotion mouse -> if ballClick s+        then s { ballPosition = mousePosition mouse }+        else s+  where+    isInside = List.elem "ball" (mouseInside $ eventMouse e)++advance :: Float -> State -> State+advance t s = s++main :: IO ()+main = do+    playRelative FullScreen white 30 initial (draw) event advance

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               gloss-relative-version:            0.1.0.0+version:            0.1.1.0 synopsis: Painless relative-sized pictures in Gloss. description: A new Frame data type for Gloss that simplifies drawing vector graphics with relative sizes and flexible layouts -- no more hardcoding distances. Bonus: graphics automatically resize when the screen changes, and native mouse hover events over defined screen regions. @@ -13,7 +13,6 @@ author:             Hugo Pacheco maintainer:         hpacheco@di.uminho.pt - category:           Graphics build-type:         Simple @@ -33,10 +32,13 @@         Graphics.Gloss.Relative.Internal.Frame         Graphics.Gloss.Relative.Internal.Picture         Graphics.Gloss.Relative.Internal.Window+        Graphics.Gloss.Relative.Internal.Raster+        Graphics.Gloss.Relative.Internal.Cache+        Graphics.Gloss.Relative.Internal.Data      -- other-extensions: -    build-depends: gloss, base < 5, mtl, containers+    build-depends: gloss, base < 5, mtl, containers, bytestring, OpenGL, gloss-rendering      hs-source-dirs:   src     default-language: GHC2021@@ -44,14 +46,24 @@ executable gloss-relative-checkers     import:           warnings     main-is:          Checkers.hs-    build-depends:    base < 5, gloss-relative+    build-depends:    base < 5, gloss-relative >= 0.1.1.0     hs-source-dirs:   examples     default-language: Haskell2010  executable gloss-relative-button     import:           warnings     main-is:          Button.hs-    build-depends:    base < 5, gloss-relative+    build-depends:    base < 5, gloss-relative >= 0.1.1.0     hs-source-dirs:   examples     default-language: Haskell2010 +executable gloss-relative-drag+    import:           warnings+    main-is:          Drag.hs+    build-depends:    base < 5, gloss-relative >= 0.1.1.0+    hs-source-dirs:   examples+    default-language: Haskell2010++source-repository head+   type:     git+   location: https://github.com/hpacheco/gloss-relative/

@@ -4,12 +4,13 @@ -- This includes the 'Frame' abstraction and helper functions. module Graphics.Gloss.Relative.Frame     ( Frame(..), Dimension(..)-    , renderStaticFrame, grid, fit, wire, solid, banner, shape, stroke, bordered+    , renderStaticFrame, grid, fit, wire, solid, banner, shape, stroke, bordered, absolute, absoluteSized, ellipsis, thickEllipsis, solidEllipsis, fixedZoom     , Alignment(..), HorizontalAlignment(..), VerticalAlignment(..)     , alignTopLeft, alignTop, alignTopRight, alignLeft, alignCenter, alignRight, alignBottomLeft, alignBottom, alignBottomRight     ) where  import Graphics.Gloss.Relative.Internal.Dimension +import Graphics.Gloss.Relative.Internal.Data import Graphics.Gloss.Relative.Internal.Frame  import Graphics.Gloss.Relative.Internal.Window hiding (grid,fit) 

@@ -11,15 +11,18 @@ import Graphics.Gloss.Data.Color import Graphics.Gloss.Relative.Frame import Graphics.Gloss.Relative.Internal.Dimension-import qualified Graphics.Gloss.Relative.Internal.Picture as Relative-import qualified Graphics.Gloss.Relative.Internal.Window as Relative-import qualified Graphics.Gloss.Relative.Internal.Frame as Relative+import qualified Graphics.Gloss.Relative.Internal.Picture as Picture+import qualified Graphics.Gloss.Relative.Internal.Window as Window+import qualified Graphics.Gloss.Relative.Internal.Frame as Frame+import qualified Graphics.Gloss.Relative.Internal.Raster as Raster+import qualified Graphics.Gloss.Relative.Internal.Cache as Cache import qualified Graphics.Gloss.Interface.Pure.Display as Gloss import qualified Graphics.Gloss.Interface.Pure.Game as Gloss import Graphics.Gloss.Interface.Pure.Game (Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..)) import qualified Graphics.Gloss.Interface.IO.Display as Gloss import Graphics.Gloss.Interface.IO.Display (Controller(..)) import qualified Graphics.Gloss.Interface.IO.Game as Gloss+import qualified Graphics.Gloss.Rendering as Gloss  import Control.Monad import qualified Data.Set as Set@@ -40,16 +43,21 @@     , mouseInside :: [String] -- ^ List of regions in which the mouse is currently inside. __Note:__ The exact regions correspond to the labels defined in the current 'Frame'.     } deriving (Eq,Show) -fromGlossEvent :: Gloss.Event -> Relative.RegionHandler -> Either Event Dimension-fromGlossEvent (Gloss.EventMotion pos) region = Left $ EventMotion (Mouse pos $ Set.toList $ region pos)-fromGlossEvent (Gloss.EventKey k st m pos) region = Left $ EventKey k st m (Mouse pos $ Set.toList $ region pos)-fromGlossEvent (Gloss.EventResize screen) region = Right (screenSizeToDimension screen)+fromGlossEvent :: Gloss.Event -> Window.RegionHandler -> IO (Either Event Dimension)+fromGlossEvent (Gloss.EventMotion pos) region = do+    rs <- region pos+    return $ Left $ EventMotion (Mouse pos $ Set.toList rs)+fromGlossEvent (Gloss.EventKey k st m pos) region = do+    rs <- region pos+    return $ Left $ EventKey k st m (Mouse pos $ Set.toList rs)+fromGlossEvent (Gloss.EventResize screen) region = do+    return $ Right (screenSizeToDimension screen)  -- | A variant of 'Gloss.display' using 'Frame'. displayRelative     :: Display          -- ^ Display mode.     -> Color            -- ^ Background color.-    -> Frame          -- ^ The frame to draw.+    -> Frame            -- ^ The frame to draw.     -> IO () displayRelative dis backColor frame = do     screen <- getDisplayDimension dis@@ -60,7 +68,7 @@ displayRelativeIO         :: Display                -- ^ Display mode.         -> Color                  -- ^ Background color.-        -> IO Frame             -- ^ Action to produce the current frame.+        -> IO Frame               -- ^ Action to produce the current frame.         -> (Controller -> IO ())  -- ^ Callback to take the display controller.         -> IO () @@ -78,7 +86,7 @@     -> Color                -- ^ Background color.     -> Int                  -- ^ Number of simulation steps to take for each second of real time.     -> world                -- ^ The initial world.-    -> (world -> Frame)   -- ^ A function to convert the world a picture.+    -> (world -> Frame)     -- ^ A function to convert the world a picture.     -> (Event -> world -> world)             -- ^ A function to handle input events.     -> (Float -> world -> world)@@ -96,7 +104,7 @@     -> Color                -- ^ Background color.     -> Int                  -- ^ Number of simulation steps to take for each second of real time.     -> world                -- ^ The initial world.-    -> (world -> IO Frame)   -- ^ A function to convert the world a picture.+    -> (world -> IO Frame)  -- ^ A function to convert the world a picture.     -> (Event -> world -> IO world)             -- ^ A function to handle input events.     -> (Float -> world -> IO world)@@ -104,19 +112,27 @@             --   It is passed the period of time (in seconds) needing to be advanced.     -> IO () playRelativeIO display backColor simResolution worldStart worldToFrame worldHandleEvent worldAdvance = do-    handler :: IORef Relative.RegionHandler <- newIORef mempty-    screen :: Dimension <- getDisplayDimension display+    handler :: IORef Window.RegionHandler <- newIORef mempty+    screen <- getDisplayScreenSize display+    let dim = screenSizeToDimension screen+    -- independent gloss state for parallel rendering+    glossState <- Gloss.initState+    cache <- Cache.newCacheTable+    currentFrame :: IORef Int <- newIORef 0 -- wraps around+    offscreen :: IORef (IO Raster.Offscreen) <- newIORef (Raster.createOffscreen screen)     let draw (w,s) = do+            i <- readIORef currentFrame             f <- worldToFrame w-            let (pic,h) = Relative.renderDynamicFrame f s-            writeIORef handler h+            (Window.WindowOutput pic h) <- Frame.renderDynamicFrame i cache glossState offscreen f s+            writeIORef handler $! h+            writeIORef currentFrame $! i + 1+            Cache.evictOldCacheTable (i+1) simResolution cache             return pic     let handleEvent ev (w,s) = do             h <- readIORef handler-            case fromGlossEvent ev h of+            fromGlossEvent ev h >>= \e -> case e of                 Left ev' -> liftM (,s) (worldHandleEvent ev' w)                 Right s' -> return (w,s')     let advance time (w,s) = liftM (,s) (worldAdvance time w)-    Gloss.playIO display backColor simResolution (worldStart,screen) draw handleEvent advance-+    Gloss.playIO display backColor simResolution (worldStart,dim) draw handleEvent advance 

@@ -0,0 +1,50 @@+module Graphics.Gloss.Relative.Internal.Cache where++import Graphics.Gloss.Relative.Internal.Window+import Graphics.Gloss.Relative.Internal.Dimension+import Graphics.Gloss.Relative.Internal.Data+import Data.Map.Strict (Map(..))+import qualified Data.Map.Strict as Map+import Data.IORef+import System.Mem.StableName+import Control.Monad.Trans++type CacheKey = (ScreenSize,String,Int)+type CacheVal = (WindowOutput,Int)+type CacheTable = IORef (Map CacheKey CacheVal)++newCacheTable :: IO CacheTable+newCacheTable = newIORef Map.empty++insertCacheTable :: Int -> CacheTable -> CacheKey -> WindowOutput -> IO ()+insertCacheTable i cache key val = do+    atomicModifyIORef' cache $ \m -> (Map.insert key (val,i) m, ())+    +lookupCacheTable :: Int -> CacheTable -> CacheKey -> IO (Maybe WindowOutput)+lookupCacheTable i cache key = do+    table <- readIORef cache+    case Map.lookup key table of+        Nothing -> return Nothing+        Just (v,_) -> do+            writeIORef cache $! Map.insert key (v,i) table+            return $ Just v++cachedRenderFrame :: Int -> CacheTable -> (String -> Frame -> Window IO ()) -> String -> Frame -> Window IO ()+cachedRenderFrame i cache render label f = do+    dim <- askDimension+    let screen = dimensionToScreenSize dim+    sn  <- liftIO $ makeStableName f+    let key = (screen,label,hashStableName sn)+    mb <- liftIO $ lookupCacheTable i cache key+    case mb of+      Just wo -> tellWindowOutput wo+      Nothing  -> do+          wo <- lift $ execWindow dim (render label f)+          liftIO $ insertCacheTable i cache key wo+          tellWindowOutput wo++evictOldCacheTable :: Int -> Int -> CacheTable -> IO ()+evictOldCacheTable frame maxAge cache = atomicModifyIORef' cache $ \m -> (Map.filter (\ce -> frame - snd ce <= maxAge) m,())+  +  +  

@@ -0,0 +1,67 @@+module Graphics.Gloss.Relative.Internal.Data where++import Graphics.Gloss+import Graphics.Gloss.Relative.Internal.Dimension++-- | A picture frame. Much like the original 'Picture' data type, but the purpose is to place and adjust pictures inside a frame with general dimensions.+data Frame+    -- | Create the largest possible frame with a desired aspect ratio within the current frame.+    = Aspect+        { aspectRatio :: Dimension -- ^ Aspect ratio dimensions.+        , aspectAlign :: Alignment -- ^ Alignment inside the parent frame.+        , aspectChild :: Frame -- ^ Child frame.+        } +    -- | Zoom the current frame by given factors, producing a smaller frame.+    | Zoom+        { zoomX :: Float -- ^ Horizontal scale (percentage between 0 and 1).+        , zoomY :: Float -- ^ Vertical scale (percentage between 0 and 1).+        , zoomAlignment :: Alignment -- ^ Alignment inside the parent frame.+        , zoomChild :: Frame -- ^ Child frame.+        }+    -- | Split the current frame into a grid with the given numbers of rows and columns. Receives a matrix of frames, represented as a list of rows.+    | Grid [[Frame]]+    -- | Labels a frame region, to use in mouse events.+    | Label+        { labelName :: String -- ^ The label for the frame region. Does not need to be unique.+        , labelTransparent :: Bool -- ^ If 'True', transparent pixels do not count for frame region selection. If 'False', the whole rectangular region is used for selection. __Note:__ Use transparency with care, ideally only for smaller regions, as performance may suffer significantly.+        , labelChild :: Frame -- ^ Current frame.+        }+    -- | Overlay a sequence of frames.+    | Frames [Frame]+    -- | Stretch picture to fill the frame, not preserving the picture's aspect ratio. If you want to preserve the aspect ratio, consider using 'fit' instead.+    | Stretch+        { stretchDimension :: Maybe Dimension -- ^ The explicit dimension of the picture, or inferred if 'Nothing'.+        , stretchPicture :: Picture -- ^ The picture to stretch to the frame's dimension.+        }+    -- | Advanced contructor. In case you need to know the exact screen size for a frame.+    | Sized (Dimension -> Frame)++-- * Alignments++-- | Alignment options for a picture or frame inside a larger frame.+data Alignment+    -- | Alignment of a child frame relative to its parent frame.+    = RelativeAlignment+        { alignH :: HorizontalAlignment -- ^ Horizontal alignment.+        , alignV :: VerticalAlignment -- ^ Vertical alignment.+        }+    -- | Advanced contructor. Absolute offset in pixels of the center of the child frame relative to its parent frame.+    -- __Note:__: The offset is truncated, so that the child frame will always remain within the parent frame.+    | AbsoluteAlignment+        { alignPos :: Point -- ^ Alignment position of the center of a child frame inside a parent frame.+        }+    deriving (Eq,Ord,Show)++-- | Horizontal alignment options for a picture or frame inside a larger frame.+data HorizontalAlignment+    = AlignLeft+    | AlignCenter  +    | AlignRight+    deriving (Eq,Ord,Show,Enum,Bounded)++-- | Vertical alignment options for a picture or frame inside a larger frame.+data VerticalAlignment+    = AlignTop+    | AlignMiddle  +    | AlignBottom+    deriving (Eq,Ord,Show,Enum,Bounded)

@@ -3,80 +3,88 @@ module Graphics.Gloss.Relative.Internal.Frame where  import Graphics.Gloss+import qualified Graphics.Gloss.Rendering as Gloss import Graphics.Gloss.Relative.Internal.Dimension-import qualified Graphics.Gloss.Relative.Internal.Picture as Relative-import qualified Graphics.Gloss.Relative.Internal.Window as Relative-import Graphics.Gloss.Relative.Internal.Window (Alignment(..), HorizontalAlignment(..), VerticalAlignment(..))+import Graphics.Gloss.Relative.Internal.Data+import qualified Graphics.Gloss.Relative.Internal.Picture as Picture+import qualified Graphics.Gloss.Relative.Internal.Window as Window+import qualified Graphics.Gloss.Relative.Internal.Raster as Raster+import qualified Graphics.Gloss.Relative.Internal.Cache as Cache  import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans+import Control.Monad.Identity (Identity(..))+import qualified Control.Monad.Identity as Identity import Data.Maybe---- | A picture frame. Much like the original 'Picture' data type, but the purpose is to place and adjust pictures inside a frame with general dimensions.-data Frame-    -- | Create the largest possible frame with a desired aspect ratio within the current frame.-    = Aspect-        { aspectRatio :: Dimension -- ^ Aspect ratio dimensions.-        , aspectAlign :: Relative.Alignment -- ^ Alignment inside the parent frame.-        , aspectChild :: Frame -- ^ Child frame.-        } -    -- | Zoom the current frame by given factors, producing a smaller frame.-    | Zoom-        { zoomX :: Float -- ^ Horizontal scale (percentage between 0 and 1).-        , zoomY :: Float -- ^ Vertical scale (percentage between 0 and 1).-        , zoomAlignment :: Relative.Alignment -- ^ Alignment inside the parent frame.-        , zoomChild :: Frame -- ^ Child frame.-        }-    -- | Split the current frame into a grid with the given numbers of rows and columns. Receives a matrix of frames, represented as a list of rows.-    | Grid [[Frame]]-    -- | Labels a frame region, to use in mouse events.-    | Label-        { labelName :: String -- ^ The label for the frame region. Does not need to be unique.-        , labelChild :: Frame -- ^ Current frame.-        }-    -- | Overlay a sequence of frames.-    | Frames [Frame]-    -- | Stretch picture to fill the frame, not preserving the picture's aspect ratio. If you want to preserve the aspect ratio, consider using 'fit' instead.-    | Stretch-        { stretchDimension :: Maybe Dimension -- ^ The explicit dimension of the picture, or inferred if 'Nothing'.-        , stretchPicture :: Picture -- ^ The picture to stretch to the frame's dimension.-        }-    -- | Advanced contructor. In case you need to know the exact screen size for a frame.-    | Sized (Dimension -> Frame)+import Data.IORef  -- | Renders a frame into a picture.  renderStaticFrame-    :: Frame -- ^ The frame to render. __Note:__ This function ignores frame labels.+    :: Frame -- ^ The frame to render. __Note:__ This function ignores frame labels. Use only if you don't need mouse hover events in this frame.     -> Dimension -- ^ The dimension of the screen in which to render the frame.     -> Picture -- ^ The resulting picture.-renderStaticFrame f screen = fst $ Relative.execWindow screen (renderFrameAsWindow f)--renderDynamicFrame :: Frame -> Dimension -> Relative.WindowOutput-renderDynamicFrame f screen = Relative.execWindow screen (renderFrameAsWindow f)+renderStaticFrame f screen = Window.wPic $ Identity.runIdentity $ Window.execWindow screen (renderStaticFrameAsWindow f)+    where+    renderStaticFrameAsWindow :: Monad m => Frame -> Window.Window m ()+    renderStaticFrameAsWindow (Aspect (aw,ah) a f) = do+        dim <- Window.askDimension+        let adim = Window.largestAspectFitDim aw ah dim+        wo <- lift $ Window.execWindow adim (renderStaticFrameAsWindow f)+        wo' <- lift $ Window.execWindow adim $ Window.fitWith adim wo+        Window.alignWith adim a wo'+    renderStaticFrameAsWindow (Zoom x y a f) = do+        (w,h) <- Window.askDimension+        let dim' = (w*x,h*y)+        wo <- lift $ Window.execWindow dim' (renderStaticFrameAsWindow f)+        Window.alignWith dim' a wo+    renderStaticFrameAsWindow (Grid xs) = do+        Window.grid (map (map renderStaticFrameAsWindow) xs)+        return ()+    renderStaticFrameAsWindow (Frames xs) = mapM_ renderStaticFrameAsWindow xs+    renderStaticFrameAsWindow (Stretch Nothing pic) = Window.stretch pic+    renderStaticFrameAsWindow (Stretch (Just dim) pic) = Window.stretchWith dim pic+    renderStaticFrameAsWindow (Sized f) = do+        dim <- Window.askDimension+        renderStaticFrameAsWindow (f dim)+    renderStaticFrameAsWindow (Label name isTransparent f) = renderStaticFrameAsWindow f -- ignores labels -renderFrameAsWindow :: Frame -> Relative.Window ()-renderFrameAsWindow (Aspect (aw,ah) a f) = do-    dim <- Relative.askDimension-    let adim = Relative.largestAspectFit aw ah dim-    let wo = Relative.execWindow adim (renderFrameAsWindow f)-    let wo' = Relative.execWindow adim $ Relative.fitWith adim wo-    Relative.alignWith adim a wo'-renderFrameAsWindow (Zoom x y a f) = do-    (w,h) <- Relative.askDimension-    let dim' = (w*x,h*y)-    let wo = Relative.execWindow dim' (renderFrameAsWindow f)-    Relative.alignWith dim' a wo-renderFrameAsWindow (Grid xs) = do-    Relative.grid (map (map renderFrameAsWindow) xs)-    return ()-renderFrameAsWindow (Frames xs) = mapM_ renderFrameAsWindow xs-renderFrameAsWindow (Stretch Nothing pic) = Relative.stretch pic-renderFrameAsWindow (Stretch (Just dim) pic) = Relative.stretchWith dim pic-renderFrameAsWindow (Sized f) = do-    dim <- Relative.askDimension-    renderFrameAsWindow (f dim)-renderFrameAsWindow (Label name f) = do-    Relative.addRegion name-    renderFrameAsWindow f+renderDynamicFrame :: Int -> Cache.CacheTable -> Gloss.State -> IORef (IO Raster.Offscreen) -> Frame -> Dimension -> IO Window.WindowOutput+renderDynamicFrame i cache state off f screen = Window.execWindow screen (renderDynamicFrameAsWindow f)+    where+    renderDynamicFrameAsWindow :: Frame -> Window.Window IO ()+    renderDynamicFrameAsWindow (Aspect (aw,ah) a f) = do+        dim <- Window.askDimension+        let adim = Window.largestAspectFitDim aw ah dim+        wo <- lift $ Window.execWindow adim (renderDynamicFrameAsWindow f)+        wo' <- lift $ Window.execWindow adim $ Window.fitWith adim wo+        Window.alignWith adim a wo'+    renderDynamicFrameAsWindow (Zoom x y a f) = do+        (w,h) <- Window.askDimension+        let dim' = (w*x,h*y)+        wo <- lift $ Window.execWindow dim' (renderDynamicFrameAsWindow f)+        Window.alignWith dim' a wo+    renderDynamicFrameAsWindow (Grid xs) = do+        Window.grid (map (map renderDynamicFrameAsWindow) xs)+        return ()+    renderDynamicFrameAsWindow (Frames xs) = mapM_ renderDynamicFrameAsWindow xs+    renderDynamicFrameAsWindow (Stretch Nothing pic) = Window.stretch pic+    renderDynamicFrameAsWindow (Stretch (Just dim) pic) = Window.stretchWith dim pic+    renderDynamicFrameAsWindow (Sized f) = do+        dim <- Window.askDimension+        renderDynamicFrameAsWindow (f dim)+    renderDynamicFrameAsWindow (Label name False f) = Window.addRegionRectangle name >> renderDynamicFrameAsWindow f+    renderDynamicFrameAsWindow (Label name True f) = Cache.cachedRenderFrame i cache renderLabel name f+        where+        renderLabel :: String -> Frame -> Window.Window IO ()+        renderLabel name f = do+            dim <- Window.askDimension+            let screen = dimensionToScreenSize dim+            o <- liftIO $ Raster.getResizeOffscreen off screen+            (Window.WindowOutput pic region) <- lift $ Window.execWindow dim (renderDynamicFrameAsWindow f)+            pic' <- liftIO $ Raster.rasterPicture state o screen pic+            Window.addRegionTransparent name pic'+            Window.tellWindowOutput (Window.WindowOutput (Raster.fromRasteredPicture pic') region)  -- | Creates each cell in a grid depending on the row and column indexes. grid :: Int -> Int -> (Int -> Int -> Frame) -> Frame@@ -84,49 +92,49 @@  -- | Alignment to the top-left of the frame. alignTopLeft :: Alignment-alignTopLeft = Alignment AlignLeft AlignTop+alignTopLeft = RelativeAlignment AlignLeft AlignTop  -- | Alignment to the top (and center) of the frame. alignTop :: Alignment-alignTop = Alignment AlignCenter AlignTop+alignTop = RelativeAlignment AlignCenter AlignTop  -- | Alignment to the top-right of the frame. alignTopRight :: Alignment-alignTopRight = Alignment AlignRight AlignTop+alignTopRight = RelativeAlignment AlignRight AlignTop  -- | Alignment to the left (and middle) the frame. alignLeft :: Alignment-alignLeft = Alignment AlignLeft AlignMiddle+alignLeft = RelativeAlignment AlignLeft AlignMiddle  -- | Alignment to the center (and middle) the frame. alignCenter :: Alignment-alignCenter = Alignment AlignCenter AlignMiddle+alignCenter = RelativeAlignment AlignCenter AlignMiddle  -- | Alignment to the right (and middle) the frame. alignRight :: Alignment-alignRight = Alignment AlignRight AlignMiddle+alignRight = RelativeAlignment AlignRight AlignMiddle  -- | Alignment to the bottom-left the frame. alignBottomLeft :: Alignment-alignBottomLeft = Alignment AlignLeft AlignBottom+alignBottomLeft = RelativeAlignment AlignLeft AlignBottom  -- | Alignment to the bottom (and middle) the frame. alignBottom :: Alignment-alignBottom = Alignment AlignCenter AlignBottom+alignBottom = RelativeAlignment AlignCenter AlignBottom  -- | Alignment to the bottom-right the frame. alignBottomRight :: Alignment-alignBottomRight = Alignment AlignRight AlignBottom+alignBottomRight = RelativeAlignment AlignRight AlignBottom  -- | Fit picture to the frame, preserving the picture's aspect ratio. Receives a picture alignment inside the frame. fit     :: Maybe Dimension -- ^ The explicit dimension of the picture, or inferred if 'Nothing'.-    -> Relative.Alignment -- ^ The alignment of the fitted picture to the current frame.+    -> Alignment -- ^ The alignment of the fitted picture to the current frame.     -> Picture -- ^ The picture to stretch to the frame's dimension.     -> Frame -- ^ The resulting frame. fit mbscreen a pic = Aspect screen a (Stretch (Just picdim) pic)     where-    picdim = Relative.pictureDimension pic+    picdim = Picture.pictureDimension pic     screen = fromMaybe picdim mbscreen  -- | Draws a picture inside a frame using the original picture dimensions, with no scaling, stretching or fitting.@@ -135,7 +143,7 @@ absolute pic = Sized $ \dim -> Stretch (Just dim) pic  -- | Draws a picture inside a frame using the original picture dimensions, with no scaling, stretching or fitting.--- Receives a function so that the picture can created depending on the current frame's size.+-- Receives a function so that the picture can be created depending on the current frame's size. -- __Warning:__ May naturally lead to misaligned pictures if not used with care. absoluteSized :: (Dimension -> Picture) -> Frame absoluteSized fpic = Sized $ \dim -> Stretch (Just dim) (fpic dim)@@ -150,14 +158,16 @@  -- | Draws a banner, that is, a piece of text fitted inside the frame, with a color. banner :: String -> Color -> Frame-banner txt c = Sized $ \dim -> fit Nothing alignCenter $ Color c $ fst $ Relative.execWindow dim (Relative.text txt)+banner txt c = Sized $ \dim -> +    let pic = Window.wPic $ Identity.runIdentity $ Window.execWindow dim (Window.text txt)+    in Stretch (Just dim) $ Color c pic  -- | A convex polygon filled with a solid color. shape     :: [Point] -- ^ A sequence of points that form the polygon. Differently from Gloss 'polygon', each coordinate of a point @(relx,rely)@ is defined as relative screen width / height percentages between @-0.5@ and @0.5@.     -> Color -- ^ The fill color.     -> Frame -- ^ The resulting frame-shape ps c = absoluteSized $ \dim -> Color c $ Polygon $ map (Relative.mulPointwise dim) ps+shape ps c = absoluteSized $ \dim -> Color c $ Polygon $ map (Picture.mulPointwise dim) ps  -- | embedding of Gloss 'polygon' with absolute sizes. absoluteShape@@ -171,7 +181,7 @@     :: [Point] -- ^ A sequence of points that form the polygon. Differently from Gloss 'polygon', each coordinate of a point @(relx,rely)@ is defined as relative screen width / height percentages between @-0.5@ and @0.5@.     -> Color -- ^ The fill color.     -> Frame -- ^ The resulting frame-stroke ps c = absoluteSized $ \dim -> Color c $ Line $ map (Relative.mulPointwise dim) ps+stroke ps c = absoluteSized $ \dim -> Color c $ Line $ map (Picture.mulPointwise dim) ps  -- | Draws a border around a smaller frame. bordered@@ -189,4 +199,31 @@         borders = [borderleft,borderright,bordertop,borderbottom]         inner = Zoom (w' / w) (h' / h) alignCenter frame     in Frames $ borders ++ [inner]++-- | Draws an ellipsis fitting the current frame.+ellipsis :: Color -> Frame+ellipsis c = absoluteSized $ \dim@(w,h) ->+    let (diameter,sx,sy) = if w < h then (w,1,h/w) else (h,w/h,1)+    in Scale sx sy $ Color c $ Circle (diameter/2)++-- | Draws an ellipsis fitting the current frame, with a given thickness.+thickEllipsis :: Color -> Float -> Frame+thickEllipsis c thick = absoluteSized $ \dim@(w,h) ->+    let (diameter,sx,sy) = if w < h then (w,1,h/w) else (h,w/h,1)+    in Scale sx sy $ Color c $ ThickCircle (diameter/2 - thick/2) thick++-- | Draws an ellipsis fitting the current frame, filled with a given color.+solidEllipsis :: Color -> Frame+solidEllipsis c = absoluteSized $ \dim@(w,h) ->+    let (diameter,sx,sy) = if w < h then (w,1,h/w) else (h,w/h,1)+        radius = diameter / 2+    in Scale sx sy $ Color c $ ThickCircle (radius/2) radius++-- | Zoom from the current frame to a smaller frame with a fixed dimension.+fixedZoom :: Dimension -> Alignment -> Frame -> Frame+fixedZoom (fw,fh) a f = Sized $ \(w,h) ->+    let zx = min 1 (fw / w)+        zy = min 1 (fh / h)+    in Zoom zx zy a f+ 

@@ -14,6 +14,20 @@ translateY :: Float -> Picture -> Picture translateY y p = Translate 0 y p +-- The default Monoid instance for 'Picture' is buggy, since Blank is not in fact a neutral element.+emptyPicture :: Picture+emptyPicture = Pictures []++joinPicture :: Picture -> Picture -> Picture+joinPicture (Pictures xs) (Pictures ys) = catPictures $ xs ++ ys+joinPicture x (Pictures ys) = catPictures (x : ys)+joinPicture (Pictures xs) y = catPictures (xs ++ [y])+joinPicture x y = catPictures [x,y]++catPictures :: [Picture] -> Picture+catPictures [x] = x+catPictures xs = Pictures xs+ -- * Regions  -- | A rectangular region within the screen.@@ -43,11 +57,22 @@  pointInsideRegion :: Point -> Region -> Bool pointInsideRegion (mouseX,mouseY) r =-    let (regionLeft,regionTop) = regionLeftTop r in-    let (w,h) = regionDimension r in-    let regionRight = regionLeft + w in-    let regionBottom = regionTop - h in-    (regionLeft <= mouseX && mouseX <= regionRight) && (regionBottom <= mouseY && mouseY <= regionTop)+    let (regionLeft,regionTop) = regionLeftTop r+        (w,h) = regionDimension r +        regionRight = regionLeft + w +        regionBottom = regionTop - h +    in (regionLeft <= mouseX && mouseX <= regionRight) && (regionBottom <= mouseY && mouseY <= regionTop)++-- converts a point inside a region to a relative point within the region+pointWithinRegion :: Point -> Region -> Maybe Point+pointWithinRegion p@(x,y) r = if pointInsideRegion p r+    then+        let (regionLeft,regionTop) = regionLeftTop r +            (w,h) = regionDimension r+            regionCenterX = regionLeft + w / 2+            regionCenterY = regionTop - h / 2+        in Just (x - regionCenterX,y - regionCenterY)+    else Nothing  translateRegionX :: Float -> Region -> Region translateRegionX f r = r { regionLeftTop = translatePointX f (regionLeftTop r) }

@@ -0,0 +1,156 @@+module Graphics.Gloss.Relative.Internal.Raster where++import Graphics.Gloss.Relative.Internal.Dimension+import Graphics.Rendering.OpenGL (($=))+import qualified Graphics.Rendering.OpenGL as GL+import Graphics.Gloss.Rendering as Gloss+import Graphics.Gloss+import Data.ByteString.Internal (create)+import Foreign.Ptr (Ptr)+import Data.Word (Word8)+import Foreign+import Foreign.ForeignPtr+import Data.Word+import Data.IORef+import Control.Monad++data Offscreen = Offscreen+    { offFBO  :: GL.FramebufferObject+    , offTex  :: GL.TextureObject+    , offDim  :: ScreenSize+    }++createOffscreen :: ScreenSize -> IO Offscreen+createOffscreen dim@(w,h) = do+    fbo <- GL.genObjectName+    GL.bindFramebuffer GL.Framebuffer $= fbo+    +    tex <- GL.genObjectName+    GL.textureBinding GL.Texture2D $= Just tex+    GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 (GL.TextureSize2D (fromIntegral w) (fromIntegral h)) 0 (GL.PixelData GL.RGBA GL.UnsignedByte nullPtr)+    +    GL.framebufferTexture2D GL.Framebuffer (GL.ColorAttachment 0) GL.Texture2D tex 0+    +    GL.drawBuffer $= GL.FBOColorAttachment 0+    GL.readBuffer $= GL.FBOColorAttachment 0+    +    status <- GL.get (GL.framebufferStatus GL.Framebuffer)+    when (status /= GL.Complete) $ error $ "Offscreen FBO incomplete " ++ show status+    +    GL.bindFramebuffer GL.Framebuffer $= GL.defaultFramebufferObject+    return Offscreen { offFBO = fbo, offTex = tex, offDim = dim }++deleteOffscreen :: Offscreen -> IO ()+deleteOffscreen off = do+  -- Unbind first+  GL.bindFramebuffer GL.Framebuffer $= GL.defaultFramebufferObject+  GL.textureBinding GL.Texture2D $= Nothing++  -- Delete GPU objects+  GL.deleteObjectName (offFBO off)+  GL.deleteObjectName (offTex off)++getResizeOffscreen :: IORef (IO Offscreen) -> ScreenSize -> IO Offscreen+getResizeOffscreen r (w,h) = do+    moff <- readIORef r+    off <- moff+    let (offw,offh) = offDim off+    off' <- if w > offw || h > offh+        then do+            deleteOffscreen off+            off' <- createOffscreen (w,h)+            return off'+        else return off+    writeIORef r $! return $! off'+    return off'+    +rasterPicture+    :: Gloss.State -> Offscreen+    -> ScreenSize+    -> Picture+    -> IO RasteredPicture+rasterPicture state offscreen dim@(w,h) pic = do+    -- Save OpenGL state+    oldVP   <- GL.get GL.viewport+    +    -- Bind offscreen target+    GL.bindFramebuffer GL.Framebuffer $= (offFBO offscreen)+    GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))+    +    -- Clear if needed (alpha = 0 for transparency)+    GL.clearColor $= GL.Color4 0 0 0 0+    GL.clear [GL.ColorBuffer]+    +    -- Set projection to match Gloss expectations+    GL.matrixMode $= GL.Projection+    GL.loadIdentity+    GL.ortho (-fromIntegral w / 2) ( fromIntegral w / 2) (-fromIntegral h / 2) ( fromIntegral h / 2) (-1) 1+    +    GL.matrixMode $= GL.Modelview 0+    GL.loadIdentity+    +    -- Render Gloss picture+    renderPicture state 1 pic+    +    -- Read pixels (RGBA, bottom-up)+    let bytes = w * h * 4+    fptr <- mallocForeignPtrBytes bytes+    withForeignPtr fptr $ \ptr ->+        GL.readPixels (GL.Position 0 0) (GL.Size (fromIntegral w) (fromIntegral h)) (GL.PixelData GL.RGBA GL.UnsignedByte ptr)+    +    -- Restore GL state+    GL.bindFramebuffer GL.Framebuffer $= GL.defaultFramebufferObject+    GL.viewport $= oldVP+    +    -- Convert to Picture+    return (dim,BitmapFormat BottomToTop PxRGBA,fptr)++type RasteredPicture = (ScreenSize,BitmapFormat,ForeignPtr Word8)++fromRasteredPicture :: RasteredPicture -> Picture+fromRasteredPicture ((w,h),fmt,fptr) = bitmapOfForeignPtr w h fmt fptr True++-- | Checks if the pixel of a certain point (with (0,0) centered in the image) is transparent.+getPixelAlpha :: RasteredPicture -> Point -> IO Word8+getPixelAlpha pic@(dim,_,_) p = do+    alpha <- lookupAlpha pic (centerToTopLeft dim p)+    return $ alpha++centerToTopLeft :: ScreenSize -> Point -> (Int,Int)+centerToTopLeft (w,h) (xc, yc) =+  ( round $ xc + realToFrac w / 2+  , round $ realToFrac h / 2 - yc+  )++topLeftToCenter :: ScreenSize -> (Int,Int) -> Point+topLeftToCenter (w,h) (xt, yt) =+  ( realToFrac xt - realToFrac w / 2+  , realToFrac h / 2 - realToFrac yt+  )++-- coordinates (x,y) with (0,0) being the top-left corner.+lookupAlpha :: RasteredPicture -> (Int,Int) -> IO Word8+lookupAlpha pic@((w,h),fmt,fptr) (x,y) =+  withForeignPtr fptr $ \ptr -> do+    let off = pixelOffset pic x y + alphaOffset (pixelFormat fmt)+    peekByteOff ptr off++alphaOffset :: PixelFormat -> Int+alphaOffset PxRGBA = 3+alphaOffset PxABGR = 0++pixelStride :: Int+pixelStride = 4++pixelOffset :: RasteredPicture -> Int -> Int -> Int+pixelOffset (dim,fmt,fptr) x y =+  let (w, h)   = dim+      BitmapFormat ro pf = fmt+      ry       = rowIndex ro h y+      base     = (ry * w + x) * pixelStride+  in base++rowIndex :: RowOrder -> Int -> Int -> Int+rowIndex TopToBottom h y = y+rowIndex BottomToTop h y = h - 1 - y+

@@ -4,59 +4,75 @@ import qualified Graphics.Gloss.Data.Point.Arithmetic as Gloss import Graphics.Gloss.Relative.Internal.Dimension import Graphics.Gloss.Relative.Internal.Picture+import Graphics.Gloss.Relative.Internal.Raster+import Graphics.Gloss.Relative.Internal.Data  import Control.Monad.Reader (Reader(..),ReaderT(..)) import qualified Control.Monad.Reader as Reader import Control.Monad.Writer (Writer(..),WriterT(..)) import qualified Control.Monad.Writer as Writer import Control.Monad+import Control.Monad.Trans+import Control.Monad.IO.Class import Data.Set (Set(..)) import qualified Data.Set as Set    -- * Window data type  -- | A function that returns which regions a position belongs to.-type RegionHandler = Point -> Set String+type RegionHandler = Point -> IO (Set String) -type WindowOutput = (Picture,RegionHandler)+data WindowOutput = WindowOutput { wPic :: Picture, wHandler :: RegionHandler } -newtype Window a = Window { unWindow :: ReaderT Dimension (Writer WindowOutput) a }+instance Semigroup WindowOutput where+    (WindowOutput p1 r1) <> (WindowOutput p2 r2) = WindowOutput (joinPicture p1 p2) (mappend r1 r2)+    +instance Monoid WindowOutput where+    mempty = WindowOutput emptyPicture mempty++newtype Window m a = Window { unWindow :: ReaderT Dimension (WriterT WindowOutput m) a }     deriving (Monad,Applicative,Functor)+    +instance MonadTrans Window where+    lift m = Window $ lift $ lift m -mkWindow :: (Dimension -> WindowOutput) -> Window ()+instance MonadIO m => MonadIO (Window m) where+    liftIO = lift . liftIO++mkWindow :: Monad m => (Dimension -> WindowOutput) -> Window m () mkWindow f = Window $ do     screen <- Reader.ask     Writer.tell $ f screen -runWindow :: Dimension -> Window a -> (a,WindowOutput)-runWindow screen (Window w) = Writer.runWriter (Reader.runReaderT w screen)+runWindow :: Monad m => Dimension -> Window m a -> m (a,WindowOutput)+runWindow screen (Window w) = Writer.runWriterT (Reader.runReaderT w screen) -execWindow :: Dimension -> Window a -> WindowOutput-execWindow screen w = snd $ runWindow screen w+execWindow :: Monad m => Dimension -> Window m a -> m WindowOutput+execWindow screen (Window w) = Writer.execWriterT (Reader.runReaderT w screen) -askDimension :: Window Dimension+askDimension :: Monad m => Window m Dimension askDimension = Window $ Reader.ask -withDimension :: (Dimension -> Dimension) -> Window a -> Window a+withDimension :: Monad m => (Dimension -> Dimension) -> Window m a -> Window m a withDimension f (Window w) = Window $ Reader.local f w -mapWindowOutput :: (WindowOutput -> WindowOutput) -> Window a -> Window a-mapWindowOutput f (Window w) = Window $ Reader.mapReaderT (Writer.mapWriter (\(x,y) -> (x,f y))) w+mapWindowOutput :: Monad m => (WindowOutput -> WindowOutput) -> Window m a -> Window m a+mapWindowOutput f (Window w) = Window $ Reader.mapReaderT (Writer.mapWriterT (\m -> m >>= \(x,y) -> return (x,f y))) w -emptyWindow :: Window ()-emptyWindow = Window $ Writer.tell (Blank,mempty)+emptyWindow :: Monad m => Window m ()+emptyWindow = tellWindowOutput mempty -tellWindowOutput :: WindowOutput -> Window ()+tellWindowOutput :: Monad m => WindowOutput -> Window m () tellWindowOutput p = Window $ Writer.tell p  -- * Window transformations    -- | Builds a grid of windows, evenly splitting the screen both horiontally and vertically.-grid :: [[Window a]] -> Window [[a]]+grid :: Monad m => [[Window m a]] -> Window m [[a]] grid = rows . map columns  -- | Evenly splits the screen vertically into a list.-rows :: [Window a] -> Window [a]+rows :: Monad m => [Window m a] -> Window m [a] rows ws = Window $ do     dim@(dimx,dimy) <- Reader.ask     let dimyn = (realToFrac dimy) / (realToFrac $ length ws)@@ -65,7 +81,7 @@     unWindow $ go ws  -- | Evenly splits the screen horizontally into a list.-columns :: [Window a] -> Window [a]+columns :: Monad m => [Window m a] -> Window m [a] columns ws = Window $ do     dim@(dimx,dimy) <- Reader.ask     let dimxn = (realToFrac dimx) / (realToFrac $ length ws)@@ -74,78 +90,72 @@     unWindow $ go ws  -- | Top-biased vertical composition of two windows. Receives height of top row.-top :: Float -> Window a -> Window b -> Window (a,b)+top :: Monad m => Float -> Window m a -> Window m b -> Window m (a,b) top sy1 w1 w2  = Window $ do     dim@(sx,sy) <- Reader.ask     let sy2 = sy - sy1-    let (a,(p1,r1)) = runWindow (sx,sy1) w1-    let (b,(p2,r2)) = runWindow (sx,sy2) w2+    (a,WindowOutput p1 r1) <- lift $ lift $ runWindow (sx,sy1) w1+    (b,WindowOutput p2 r2) <- lift $ lift $ runWindow (sx,sy2) w2     let p12 = Pictures [translateY (realToFrac sy2/2) p1,translateY (-realToFrac sy1/2) p2]-    let r12 pos = Set.unions [r1 $ translatePointY (-realToFrac sy2/2) pos, r2 $ translatePointY (realToFrac sy1/2) pos]-    Writer.tell (p12,r12)+    let r12 pos = do+            m1 <- r1 $ translatePointY (-realToFrac sy2/2) pos+            m2 <- r2 $ translatePointY (realToFrac sy1/2) pos+            return $ Set.unions [m1,m2]+    Writer.tell (WindowOutput p12 r12)     return (a,b)  -- | Bottom-biased vertical composition of two windows. Receives height of bottom row.-bottom :: Float -> Window a -> Window b -> Window (a,b)+bottom :: Monad m => Float -> Window m a -> Window m b -> Window m (a,b) bottom sy2 w1 w2 = do     (w,h) <- askDimension     top (h-sy2) w1 w2  -- Left-biased horizontal composition of two windows. Receives width of left column.-left :: Float -> Window a -> Window b -> Window (a,b)+left :: Monad m => Float -> Window m a -> Window m b -> Window m (a,b) left sx1 w1 w2 = Window $ do     (sx,sy) <- Reader.ask     let sx2 = sx - sx1-    let (a,(p1,r1)) = runWindow (sx1,sy) w1-    let (b,(p2,r2)) = runWindow (sx2,sy) w2+    (a,WindowOutput p1 r1) <- lift $ lift $ runWindow (sx1,sy) w1+    (b,WindowOutput p2 r2) <- lift $ lift $ runWindow (sx2,sy) w2     let p12 = Pictures [translateX (-realToFrac sx2/2) p1,translateX (realToFrac sx1/2) p2]-    let r12 pos = Set.unions [r1 $ translatePointX (realToFrac sx2/2) pos,r2 $ translatePointX (-realToFrac sx1/2) pos]-    Writer.tell (p12,r12)+    let r12 pos = do+            m1 <- r1 $ translatePointX (realToFrac sx2/2) pos+            m2 <- r2 $ translatePointX (-realToFrac sx1/2) pos+            return $ Set.unions [m1,m2]+    Writer.tell (WindowOutput p12 r12)     return (a,b)  -- Right-biased horizontal composition of two windows. Receives width of right column.-right :: Float -> Window a -> Window b -> Window (a,b)+right :: Monad m => Float -> Window m a -> Window m b -> Window m (a,b) right sx2 w1 w2 = do     (w,h) <- askDimension     left (w-sx2) w1 w2  -- | Stretches a picture to fit the window-stretchWith :: Dimension -> Picture -> Window ()+stretchWith :: Monad m => Dimension -> Picture -> Window m () stretchWith (cx,cy) pic = Window $ do     screen@(sx,sy) <- Reader.ask     let scalex = max 0 (realToFrac sx / realToFrac cx)         scaley = max 0 (realToFrac sy / realToFrac cy)-    Writer.tell (Scale scalex scaley pic,mempty)+    Writer.tell (WindowOutput (Scale scalex scaley pic) mempty)     return () -stretch :: Picture -> Window ()+stretch :: Monad m => Picture -> Window m () stretch pic = stretchWith (pictureDimension pic) pic -align :: Alignment -> Dimension -> Dimension -> (Float,Float)-align (Alignment ha va) c s = halign ha c s Gloss.+ valign va c s-    -halign :: HorizontalAlignment -> Dimension -> Dimension -> (Float,Float)-halign a (cx,cy) (sx,sy) = case a of-    AlignLeft   -> (-((sx-cx)/2),0)-    AlignRight  -> (((sx-cx)/2),0)-    AlignCenter -> (0,0)--valign :: VerticalAlignment -> Dimension -> Dimension -> (Float,Float)-valign a (cx,cy) (sx,sy) = case a of-    AlignTop    -> (0,((sy-cy)/2))-    AlignBottom -> (0,-((sy-cy)/2))-    AlignMiddle -> (0,0)--alignWith :: Dimension -> Alignment -> WindowOutput -> Window ()-alignWith dim a (pic,region) = Window $ do+alignWith :: Monad m => Dimension -> Alignment -> WindowOutput -> Window m ()+alignWith dim a (WindowOutput pic region) = Window $ do     screen <- Reader.ask-    let (ax,ay) = align a dim screen+    let (ax,ay) = alignCoords a dim screen     let pic' = translateX ax $ translateY ay pic     let region' pos = region $ translatePointX (-ax) $ translatePointY (-ay) pos-    Writer.tell (pic',region')+    Writer.tell (WindowOutput pic' region') -fitWith :: Dimension -> WindowOutput -> Window ()-fitWith (cx,cy) (pic,region) = Window $ do+align :: Monad m => Alignment -> WindowOutput -> Window m ()+align a (WindowOutput pic region) = alignWith (pictureDimension pic) a (WindowOutput pic region)++fitWith :: Monad m => Dimension -> WindowOutput -> Window m ()+fitWith (cx,cy) (WindowOutput pic region) = Window $ do     (sx,sy) <- Reader.ask     let scalex = sx / cx     let scaley = sy / cy@@ -153,18 +163,13 @@     let dim' = (cx*scalexy,cy*scalexy)     let pic' = Scale scalexy scalexy pic     let region' pos = region $ scalePoint (1/scalexy) (1/scalexy) pos-    Writer.tell (pic',region')--fit :: WindowOutput -> Window ()-fit (pic,region) = fitWith (pictureDimension pic) (pic,region)+    Writer.tell (WindowOutput pic' region') -largestAspectFit :: Float -> Float -> Dimension -> Dimension-largestAspectFit a b (screenW,screenH)-  | screenW / screenH >= a / b = (screenH * (a / b), screenH)-  | otherwise                  = (screenW, screenW * (b / a))+fit :: Monad m => WindowOutput -> Window m ()+fit (WindowOutput pic region) = fitWith (pictureDimension pic) (WindowOutput pic region) -text :: String -> Window ()-text str = fitWith dim (pic,mempty)+text :: Monad m => String -> Window m ()+text str = fitWith dim (WindowOutput pic mempty)     where     textWidth = realToFrac (length str) * (realToFrac charWidth)     pic = Translate (-realToFrac textWidth/2) (-realToFrac charHeight/2) $ Text str@@ -172,33 +177,52 @@  -- * Regions --- | Registers a new region for the current window-addRegion :: String -> Window ()-addRegion name = do+-- | Registers a new region for the current window, as a rectangle.+addRegionRectangle :: Monad m => String -> Window m ()+addRegionRectangle name = do     dim <- askDimension     let reg = dimensionToRegion dim-    tellWindowOutput (Blank,\p -> if pointInsideRegion p reg then Set.singleton name else Set.empty)---- * Alignment types+    let react p = if pointInsideRegion p reg+            then return $ Set.singleton name+            else return Set.empty+    tellWindowOutput $ WindowOutput emptyPicture react --- | Alignment options for a picture or frame inside a larger frame.-data Alignment = Alignment-  { alignH :: HorizontalAlignment -- ^ Horizontal alignment.-  , alignV :: VerticalAlignment -- ^ Vertical alignment.-  } deriving (Eq,Ord,Show)+-- | Registers a new region for the current window, pixel-wise. +addRegionTransparent :: Monad m => String -> RasteredPicture -> Window m ()+addRegionTransparent name pic = do+    dim <- askDimension+    let reg = dimensionToRegion dim+    let react p = case pointWithinRegion p reg of+            Nothing -> return Set.empty+            Just p' -> getPixelAlpha pic p' >>= \alpha -> if alpha > 0+                then return $ Set.singleton name +                else return $ Set.empty+    tellWindowOutput $ WindowOutput emptyPicture react --- | Horizontal alignment options for a picture or frame inside a larger frame.-data HorizontalAlignment-    = AlignLeft-    | AlignCenter  -    | AlignRight-    deriving (Eq,Ord,Show,Enum,Bounded)+-- * Alignments --- | Vertical alignment options for a picture or frame inside a larger frame.-data VerticalAlignment-    = AlignTop-    | AlignMiddle  -    | AlignBottom-    deriving (Eq,Ord,Show,Enum,Bounded)+alignCoords :: Alignment -> Dimension -> Dimension -> (Float,Float)+alignCoords (RelativeAlignment ha va) c s = halignCoords ha c s Gloss.+ valignCoords va c s+alignCoords (AbsoluteAlignment (x,y)) (cx,cy) (sx,sy) = (ax,ay)+    where+    hborder = sx / 2 - cx / 2+    vborder = sy / 2 - cy / 2+    ax = min hborder $ max (-hborder) x+    ay = min vborder $ max (-vborder) y+    +halignCoords :: HorizontalAlignment -> Dimension -> Dimension -> (Float,Float)+halignCoords a (cx,cy) (sx,sy) = case a of+    AlignLeft   -> (-((sx-cx)/2),0)+    AlignRight  -> (((sx-cx)/2),0)+    AlignCenter -> (0,0) +valignCoords :: VerticalAlignment -> Dimension -> Dimension -> (Float,Float)+valignCoords a (cx,cy) (sx,sy) = case a of+    AlignTop    -> (0,((sy-cy)/2))+    AlignBottom -> (0,-((sy-cy)/2))+    AlignMiddle -> (0,0) +largestAspectFitDim :: Float -> Float -> Dimension -> Dimension+largestAspectFitDim a b (screenW,screenH)+  | screenW / screenH >= a / b = (screenH * (a / b), screenH)+  | otherwise                  = (screenW, screenW * (b / a))