packages feed

gloss-relative (empty) → 0.1.0.0

raw patch · 12 files changed

+961/−0 lines, 12 filesdep +basedep +containersdep +gloss

Dependencies added: base, containers, gloss, gloss-relative, mtl

Files

+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2025, Hugo Pacheco+++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.++    * Neither the name of the copyright holder nor the names of its+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++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 OR CONTRIBUTORS 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.
+ README.md view
@@ -0,0 +1,27 @@++# Gloss Relative++This library is an extension to Gloss to reduce some of the pain of designing graphics with sizes relative to the screen dimensions.++## Usage++This package is defined as a replacement with batteries for the standard:++```+import Graphics.Gloss +```++Just replace with the new import to get the original Gloss functionality plus the 'Frame' abstraction.++```+import Graphics.Gloss.Relative +```++## Examples++You can play with a few examples that illustrate how the library can be used:++```+cabal run gloss-relative-checkers+cabal run gloss-relative-button+```
+ examples/Button.hs view
@@ -0,0 +1,34 @@+module Main where++import Graphics.Gloss.Relative++import Data.List as List++data State = State { pressed :: Bool, selected :: Bool }++initial :: State+initial = State False False++draw :: State -> Frame+draw st = Zoom 0.5 0.5 alignCenter $ bordered 10 borderc $ Label "button" $ Frames [solid c,labels]+    where+    borderc = if pressed st then red else c+    c = if selected st then grey else black+    labels = Grid [[banner "Press" red],[banner "Hover" grey]]+    grey = greyN 0.5++event :: Event -> State -> State+event e s = case e of+        EventKey { eventKey = MouseButton LeftButton, eventKeyState = st } -> case st of+            Down -> if isInside then s' { pressed = True } else s'+            Up -> s' { pressed = False }+        otherwise -> s'+    where+    isInside = List.elem "button" (mouseInside $ eventMouse e)+    s' = s { selected = isInside }++advance :: Float -> State -> State+advance t s = s++main :: IO ()+main = playRelative FullScreen white 30 initial draw event advance
+ examples/Checkers.hs view
@@ -0,0 +1,24 @@+module Main where++import Graphics.Gloss.Relative++lightWood :: Color+lightWood = makeColorI 222 184 135 255++darkWood :: Color+darkWood = makeColorI 62 49 49 255++draw :: Frame+draw = Aspect (11,11) alignCenter $ Frames [border,slots]+    where+    border = solid darkWood+    slots = Zoom (10/11) (10/11) alignCenter $ grid 10 10 drawSlot++drawSlot :: Int -> Int -> Frame+drawSlot i j = if even i == even j+    then solid white +    else solid black ++main :: IO ()+main = do+    displayRelative FullScreen lightWood draw
+ gloss-relative.cabal view
@@ -0,0 +1,57 @@+cabal-version:      3.0+name:               gloss-relative+version:            0.1.0.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.++license:            BSD-3-Clause+license-file:       LICENSE++extra-doc-files:+  README.md++author:             Hugo Pacheco+maintainer:         hpacheco@di.uminho.pt+++category:           Graphics+build-type:         Simple++common warnings+    ghc-options:++library+    import:           warnings++    exposed-modules:+        Graphics.Gloss.Relative+        Graphics.Gloss.Relative.Frame+        Graphics.Gloss.Relative.Interface++    other-modules:+        Graphics.Gloss.Relative.Internal.Dimension+        Graphics.Gloss.Relative.Internal.Frame+        Graphics.Gloss.Relative.Internal.Picture+        Graphics.Gloss.Relative.Internal.Window++    -- other-extensions:++    build-depends: gloss, base < 5, mtl, containers++    hs-source-dirs:   src+    default-language: GHC2021++executable gloss-relative-checkers+    import:           warnings+    main-is:          Checkers.hs+    build-depends:    base < 5, gloss-relative+    hs-source-dirs:   examples+    default-language: Haskell2010++executable gloss-relative-button+    import:           warnings+    main-is:          Button.hs+    build-depends:    base < 5, gloss-relative+    hs-source-dirs:   examples+    default-language: Haskell2010+
+ src/Graphics/Gloss/Relative.hs view
@@ -0,0 +1,11 @@+-- | Module that wraps all the functionality of @gloss-relative@ and the core functionality of @gloss@.+module Graphics.Gloss.Relative+    ( module Graphics.Gloss.Relative.Frame+    , module Graphics.Gloss.Relative.Interface+    , module Graphics.Gloss+    ) where++import Graphics.Gloss.Relative.Frame+import Graphics.Gloss.Relative.Interface++import Graphics.Gloss
+ src/Graphics/Gloss/Relative/Frame.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE ViewPatterns #-}++-- | The core functionality of the @gloss-relative@ package is exported in this module.+-- This includes the 'Frame' abstraction and helper functions.+module Graphics.Gloss.Relative.Frame+    ( Frame(..), Dimension(..)+    , renderStaticFrame, grid, fit, wire, solid, banner, shape, stroke, bordered+    , Alignment(..), HorizontalAlignment(..), VerticalAlignment(..)+    , alignTopLeft, alignTop, alignTopRight, alignLeft, alignCenter, alignRight, alignBottomLeft, alignBottom, alignBottomRight+    ) where++import Graphics.Gloss.Relative.Internal.Dimension +import Graphics.Gloss.Relative.Internal.Frame +import Graphics.Gloss.Relative.Internal.Window hiding (grid,fit)+
+ src/Graphics/Gloss/Relative/Interface.hs view
@@ -0,0 +1,122 @@+-- | Various game modes using frames instead of pictures.+module Graphics.Gloss.Relative.Interface+        ( module Graphics.Gloss.Data.Display+        , module Graphics.Gloss.Data.Picture+        , module Graphics.Gloss.Data.Color+        , displayRelative, displayRelativeIO, playRelative, playRelativeIO+        , Controller(..), Event(..), Mouse(..), Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..))+where+import Graphics.Gloss.Data.Display+import Graphics.Gloss.Data.Picture+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.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 Control.Monad+import qualified Data.Set as Set+import Data.IORef+import System.Exit++-- | A custom Gloss event type that knows about frame regions.+data Event+    -- | A key press.+    = EventKey { eventKey :: Key, eventKeyState :: KeyState, eventModifiers :: Modifiers, eventMouse :: Mouse }+    -- | A mouse movement.+    | EventMotion { eventMouse :: Mouse }+    deriving (Eq, Show)++-- | Information about the mouse.+data Mouse = Mouse+    { mousePosition :: Point -- ^ Current mouse position.+    , 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)++-- | A variant of 'Gloss.display' using 'Frame'.+displayRelative+    :: Display          -- ^ Display mode.+    -> Color            -- ^ Background color.+    -> Frame          -- ^ The frame to draw.+    -> IO ()+displayRelative dis backColor frame = do+    screen <- getDisplayDimension dis+    let pic = renderStaticFrame frame screen+    Gloss.display dis backColor pic++-- | A variant of 'Gloss.displayIO' using 'Frame'.+displayRelativeIO+        :: Display                -- ^ Display mode.+        -> Color                  -- ^ Background color.+        -> IO Frame             -- ^ Action to produce the current frame.+        -> (Controller -> IO ())  -- ^ Callback to take the display controller.+        -> IO ()++displayRelativeIO dis backColor makeFrame eatController = do+    screen <- getDisplayDimension dis+    let makePicture = do+            frame <- makeFrame+            let pic = renderStaticFrame frame screen+            return pic+    Gloss.displayIO dis backColor makePicture eatController++-- | A variant of 'Gloss.play' using 'Frame'. The resulting picture is automatically redimensioned on resize events.+playRelative+    :: Display              -- ^ Display mode.+    -> 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.+    -> (Event -> world -> world)+            -- ^ A function to handle input events.+    -> (Float -> world -> world)+            -- ^ A function to step the world one iteration.+            --   It is passed the period of time (in seconds) needing to be advanced.+    -> IO ()+playRelative display backColor simResolution worldStart worldToFrame worldHandleEvent worldAdvance = do+    let handleEvent (EventKey (Gloss.SpecialKey Gloss.KeyEsc) Gloss.Down _ _) st = exitSuccess+        handleEvent ev st = return $ worldHandleEvent ev st+    playRelativeIO display backColor simResolution worldStart (return . worldToFrame) handleEvent (\x -> return . worldAdvance x)++-- | A variant of 'Gloss.playIO' using 'Frame'. The resulting picture is automatically redimensioned on resize events.+playRelativeIO+    :: Display              -- ^ Display mode.+    -> 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.+    -> (Event -> world -> IO world)+            -- ^ A function to handle input events.+    -> (Float -> world -> IO world)+            -- ^ A function to step the world one iteration.+            --   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+    let draw (w,s) = do+            f <- worldToFrame w+            let (pic,h) = Relative.renderDynamicFrame f s+            writeIORef handler h+            return pic+    let handleEvent ev (w,s) = do+            h <- readIORef handler+            case fromGlossEvent ev h 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++
+ src/Graphics/Gloss/Relative/Internal/Dimension.hs view
@@ -0,0 +1,28 @@+module Graphics.Gloss.Relative.Internal.Dimension where++import qualified Graphics.Gloss as Gloss+import Graphics.Gloss.Data.Display+import Graphics.Gloss.Interface.Environment++import Control.Monad++-- | A dimension is pair @(width,height)@.+-- When used as a screen size, the position @(0,0)@ is considered to be at the center.+type Dimension = (Float,Float)++-- | A screen size screen size is a 'Dimension' in pixels, where the position @(0,0)@ is at the center.+type ScreenSize = (Int,Int)++-- | Gets the dimension of a Gloss 'Display'.+getDisplayScreenSize :: Display -> IO ScreenSize +getDisplayScreenSize (InWindow _ dim _) = return dim+getDisplayScreenSize (FullScreen) = getScreenSize++getDisplayDimension :: Display -> IO Dimension +getDisplayDimension = liftM screenSizeToDimension . getDisplayScreenSize++screenSizeToDimension :: ScreenSize -> Dimension+screenSizeToDimension (w,h) = (realToFrac w,realToFrac h)++dimensionToScreenSize :: Dimension -> ScreenSize+dimensionToScreenSize (w,h) = (ceiling w,ceiling h)
+ src/Graphics/Gloss/Relative/Internal/Frame.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE ViewPatterns #-}++module Graphics.Gloss.Relative.Internal.Frame where++import Graphics.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 Control.Monad+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)++-- | Renders a frame into a picture. +renderStaticFrame+    :: Frame -- ^ The frame to render. __Note:__ This function ignores frame labels.+    -> 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)++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++-- | Creates each cell in a grid depending on the row and column indexes.+grid :: Int -> Int -> (Int -> Int -> Frame) -> Frame+grid ncols nrows mk = Grid $ map (\row -> map (\col -> mk row col) [0..ncols-1]) [0..nrows-1] ++-- | Alignment to the top-left of the frame.+alignTopLeft :: Alignment+alignTopLeft = Alignment AlignLeft AlignTop++-- | Alignment to the top (and center) of the frame.+alignTop :: Alignment+alignTop = Alignment AlignCenter AlignTop++-- | Alignment to the top-right of the frame.+alignTopRight :: Alignment+alignTopRight = Alignment AlignRight AlignTop++-- | Alignment to the left (and middle) the frame.+alignLeft :: Alignment+alignLeft = Alignment AlignLeft AlignMiddle++-- | Alignment to the center (and middle) the frame.+alignCenter :: Alignment+alignCenter = Alignment AlignCenter AlignMiddle++-- | Alignment to the right (and middle) the frame.+alignRight :: Alignment+alignRight = Alignment AlignRight AlignMiddle++-- | Alignment to the bottom-left the frame.+alignBottomLeft :: Alignment+alignBottomLeft = Alignment AlignLeft AlignBottom++-- | Alignment to the bottom (and middle) the frame.+alignBottom :: Alignment+alignBottom = Alignment AlignCenter AlignBottom++-- | Alignment to the bottom-right the frame.+alignBottomRight :: Alignment+alignBottomRight = Alignment 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.+    -> 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+    screen = fromMaybe picdim mbscreen++-- | Draws a picture inside a frame using the original picture dimensions, with no scaling, stretching or fitting.+-- __Warning:__ May naturally lead to misaligned pictures if not used with care.+absolute :: Picture -> Frame+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.+-- __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)++-- | Paints the borders of the frame with a color.+wire :: Color -> Frame+wire c = Stretch Nothing $ Color c $ rectangleWire 10 10 -- any dimension would work here++-- | Paints the frame with a solid color.+solid :: Color -> Frame+solid c = Stretch Nothing $ Color c $ rectangleSolid 10 10 -- any dimension would work here++-- | 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)++-- | 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++-- | embedding of Gloss 'polygon' with absolute sizes.+absoluteShape+    :: [Point] +    -> Color +    -> Frame +absoluteShape ps c = absoluteSized $ \dim -> Color c $ Polygon ps++-- | A line connecting a sequence of points, drawn with a color.+stroke+    :: [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++-- | Draws a border around a smaller frame.+bordered+    :: Float -- ^ A fixed thickness in pixels.+    -> Color -- ^ The color for the border.+    -> Frame -- ~ The inner frame, whose screen dimension is smaller by the defined thickness.+    -> Frame -- ^ The resulting frame.+bordered thick c frame = Sized $ \dim@(w,h) ->+    let w' = max 0 (w-thick)+        h' = max 0 (h-thick)+        borderleft = absoluteShape [(-w/2,-h/2),(-w/2,h/2),(-w'/2,h/2),(-w'/2,-h/2)] c+        borderright = absoluteShape [(w/2,-h/2),(w/2,h/2),(w'/2,h/2),(w'/2,-h/2)] c+        bordertop = absoluteShape [(-w/2,h/2),(w/2,h/2),(w/2,h'/2),(-w/2,h'/2)] c+        borderbottom = absoluteShape [(-w/2,-h/2),(w/2,-h/2),(w/2,-h'/2),(-w/2,-h'/2)] c+        borders = [borderleft,borderright,bordertop,borderbottom]+        inner = Zoom (w' / w) (h' / h) alignCenter frame+    in Frames $ borders ++ [inner]+
+ src/Graphics/Gloss/Relative/Internal/Picture.hs view
@@ -0,0 +1,218 @@+module Graphics.Gloss.Relative.Internal.Picture where++import Graphics.Gloss+import Graphics.Gloss.Relative.Internal.Dimension++import Data.Semigroup+import Data.Monoid++-- * Pictures++translateX :: Float -> Picture -> Picture+translateX x p = Translate x 0 p++translateY :: Float -> Picture -> Picture+translateY y p = Translate 0 y p++-- * Regions++-- | A rectangular region within the screen.+data Region = Region+    { regionLeftTop :: Point+    , regionDimension :: Dimension+    } deriving (Eq,Ord,Show)++instance Semigroup Region where+    (Region (x1,y1) (w1,h1)) <> (Region (x2,y2) (w2,h2)) = Region (xmin,ymin) (abs (xmax-xmin),abs (ymax-ymin))+         where xmin = min x1 x2+               ymin = min y1 y2+               xmax = max (x1+w1) (x2+w2)+               ymax = max (y1+h1) (y2+h2)++instance Monoid Region where+    mempty = Region (0,0) (0,0)++regionScreenSize :: Region -> ScreenSize+regionScreenSize (Region (x,y) (xdim,ydim)) = (ceiling $ maxX * 2,ceiling $ maxY * 2)+    where+    maxX = max (abs x) (abs $ x + xdim)+    maxY = max (abs y) (abs $ y + ydim)++dimensionToRegion :: Dimension -> Region+dimensionToRegion (w,h) = Region { regionLeftTop = (-w/2,h/2), regionDimension = (w,h) }++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)++translateRegionX :: Float -> Region -> Region+translateRegionX f r = r { regionLeftTop = translatePointX f (regionLeftTop r) }++translateRegionY :: Float -> Region -> Region+translateRegionY f r = r { regionLeftTop = translatePointY f (regionLeftTop r) }++-- * Picture bounding box++-- | Estimates the 'Region' of a 'Picture'.+pictureRegion :: Picture -> Region+pictureRegion = bbToRegion . bbox++pictureScreenSize :: Picture -> ScreenSize+pictureScreenSize = regionScreenSize . pictureRegion ++pictureDimension :: Picture -> Dimension+pictureDimension = screenSizeToDimension . pictureScreenSize++type Elipsis = (Float,Float,Float,Float,Float,Float)+data BB = BB { bbElipsis :: [Elipsis], bbPoints :: [Point] } deriving Show++instance Semigroup BB where+    (BB es1 ps1) <> (BB es2 ps2) = BB (es1++es2) (ps1++ps2)+instance Monoid BB where+    mempty = BB [] []++bbox :: Picture -> BB+bbox Blank = mempty+bbox (Polygon l) = BB [] l+bbox (Line l) = BB [] l+bbox (Circle r) = case (circElipsis r) of+    Nothing -> mempty+    Just e -> BB [e] []+bbox (ThickCircle r thick) = case (circElipsis $ r + thick / 2) of+    Nothing -> mempty+    Just e -> BB [e] []+bbox (Arc _ _ r) = bbox (Circle r) -- big overapproximation+bbox (ThickArc _ _ r thick) = bbox (ThickCircle r thick) -- big overapproximation+bbox (Text str) = bbox $ Translate (textWidth/2) (fromIntegral charHeight/2) rect+    where+    rect = rectangleWire textWidth (realToFrac charHeight)+    textWidth = realToFrac (length str) * (realToFrac charWidth)+bbox (Bitmap bmp) = bbox $ rectangleWire (fromIntegral w) (fromIntegral h)+    where (w,h) = bitmapSize bmp+bbox (BitmapSection rect bmp) = bbox $ rectangleWire (fromIntegral w) (fromIntegral h)+    where (w,h) = rectSize rect+bbox (Color c p) = bbox p+bbox (Scale x y p) = scaleBB x y (bbox p)+bbox (Translate x y p) = translateBB x y (bbox p)+bbox (Rotate alpha p) = rotateBB alpha (bbox p)+bbox (Pictures xs) = mconcat $ map bbox xs++charHeight :: Int+charHeight =  104+charWidth :: Int+charWidth = 70++scaleBB :: Float -> Float -> BB -> BB+scaleBB x y (BB es ps) = BB (map (scaleElipsis x y) es) (scalePath x y ps)++translateBB :: Float -> Float -> BB -> BB+translateBB x y (BB es ps) = BB (map (translateElipsis x y) es) (translatePath x y ps)++rotateBB :: Float -> BB -> BB+rotateBB alpha (BB es ps) = BB (map (rotateElipsis alpha) es) (rotatePath alpha ps)++bbToRegion :: BB -> Region+bbToRegion (BB es ps) = mconcat $ pathRegion ps : map elipsisRegion es++pathRegion :: Path -> Region+pathRegion [] = mempty+pathRegion l = Region (xmin,ymin) (abs (xmax-xmin),abs (ymax-ymin))+ where (xs,ys) = unzip l+       xmin = minimum xs+       ymin = minimum ys+       xmax = maximum xs+       ymax = maximum ys++elipsisRegion :: Elipsis -> Region+elipsisRegion (a,b,c,d,e,f) | dlt==0 = mempty+                        | otherwise = Region (xl,yb) (abs (xr-xl),abs (yt-yb))+ where dlt = 4*a*c - b^2+       xc = (b*e - 2*c*d) / dlt+       yc = (b*d - 2*a*e) / dlt+       xr = xc + sqrt ((2*b*e-4*c*d)^2+4*dlt*(e^2-4*c*f)) / (2*dlt)+       yt = yc + sqrt ((2*b*d-4*a*e)^2+4*dlt*(d^2-4*a*f)) / (2*dlt)+       xl = xc - sqrt ((2*b*e-4*c*d)^2+4*dlt*(e^2-4*c*f)) / (2*dlt)+       yb = yc - sqrt ((2*b*d-4*a*e)^2+4*dlt*(d^2-4*a*f)) / (2*dlt)++-- converts point from cartesian to polar coordinates+toPolar :: Point -> (Float,Float)+toPolar (x,y) = (sqrt (x^2+y^2), atan2 y x)++-- converts point from polar to cartesian+toCartesian :: (Float,Float) -> Point+toCartesian (r,gama) = (r*cos gama,r*sin gama)++-- a circle as an elipsis+circElipsis :: Float -> Maybe Elipsis+circElipsis 0 = Nothing+circElipsis r = Just (1/r^2,0,1/r^2,0,0,-1)++rotatePoint :: Float -> Point -> Point+rotatePoint alpha (x,y) = toCartesian (r,gama + (rad (-alpha)))+ where (r,gama) = toPolar (x,y)+ +rotatePath :: Float -> Path -> Path+rotatePath alpha = map (rotatePoint alpha)++rotateElipsis :: Float -> Elipsis -> Elipsis+rotateElipsis alpha (a,b,c,d,e,f) = (a',b',c',d',e',f')+ where theta = rad (alpha)+       a' = a*(cos theta)^2 + b*sin theta*cos theta + c*(sin theta)^2+       b' = 2*(c-a)*sin theta*cos theta + b*((cos theta)^2-(sin theta)^2)+       c' = a*(sin theta)^2 - b*sin theta*cos theta + c*(cos theta)^2+       d' = d*cos theta + e*sin theta+       e' = -d*sin theta + e*cos theta+       f' = f++translatePoint :: Float -> Float -> Point -> Point+translatePoint x y (a,b) = (a+x,b+y)++translatePointX :: Float -> Point -> Point+translatePointX f (x,y) = (x+f,y)++translatePointY :: Float -> Point -> Point+translatePointY f (x,y) = (x,y+f)++translatePath :: Float -> Float -> Path -> Path+translatePath x y = map (translatePoint x y)++translateElipsis :: Float -> Float -> Elipsis -> Elipsis+translateElipsis x y (a,b,c,d,e,f) = (a',b',c',d',e',f')+ where a' = a+       b' = b+       c' = c+       d' = d - 2*a*x - b*y+       e' = e - b*x - 2*c*y+       f' = f + a*x^2 + b*x*y + c*y^2 - d*x -e*y++scalePoint :: Float -> Float -> Point -> Point+scalePoint xs ys (x,y) = (x*xs,y*ys)++scalePath :: Float -> Float -> Path -> Path+scalePath xs ys = map (scalePoint xs ys)++scaleElipsis :: Float -> Float -> Elipsis -> Elipsis+scaleElipsis xs ys (a,b,c,d,e,f) = (a',b',c',d',e',f')+ where a' = a / (xs^2)+       b' = b / (xs * ys)+       c' = c / (ys^2)+       d' = d / xs+       e' = e / ys+       f' = f++mulPointwise :: Point -> Point -> Point+mulPointwise (a,b) (c,d) = (a*c,b*d)++-- * Auxiliary functions++-- | Converts degrees to radians+rad :: Float -> Float+rad alpha = alpha * pi / 180++-- | Converts radians to degrees+deg :: Float -> Float+deg alpha = alpha * 180 / pi
+ src/Graphics/Gloss/Relative/Internal/Window.hs view
@@ -0,0 +1,204 @@+module Graphics.Gloss.Relative.Internal.Window where+  +import Graphics.Gloss+import qualified Graphics.Gloss.Data.Point.Arithmetic as Gloss+import Graphics.Gloss.Relative.Internal.Dimension+import Graphics.Gloss.Relative.Internal.Picture++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 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 WindowOutput = (Picture,RegionHandler)++newtype Window a = Window { unWindow :: ReaderT Dimension (Writer WindowOutput) a }+    deriving (Monad,Applicative,Functor)++mkWindow :: (Dimension -> WindowOutput) -> Window ()+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)++execWindow :: Dimension -> Window a -> WindowOutput+execWindow screen w = snd $ runWindow screen w++askDimension :: Window Dimension+askDimension = Window $ Reader.ask++withDimension :: (Dimension -> Dimension) -> Window a -> Window 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++emptyWindow :: Window ()+emptyWindow = Window $ Writer.tell (Blank,mempty)++tellWindowOutput :: WindowOutput -> Window ()+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 = rows . map columns++-- | Evenly splits the screen vertically into a list.+rows :: [Window a] -> Window [a]+rows ws = Window $ do+    dim@(dimx,dimy) <- Reader.ask+    let dimyn = (realToFrac dimy) / (realToFrac $ length ws)+    let go [] = fmap (Prelude.const []) emptyWindow+        go (x:xs) = fmap (uncurry (:)) (top dimyn x (go xs))+    unWindow $ go ws++-- | Evenly splits the screen horizontally into a list.+columns :: [Window a] -> Window [a]+columns ws = Window $ do+    dim@(dimx,dimy) <- Reader.ask+    let dimxn = (realToFrac dimx) / (realToFrac $ length ws)+    let go [] = fmap (Prelude.const []) emptyWindow+        go (x:xs) = fmap (uncurry (:)) (left dimxn x (go xs))+    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 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+    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)+    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 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 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+    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)+    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 sx2 w1 w2 = do+    (w,h) <- askDimension+    left (w-sx2) w1 w2++-- | Stretches a picture to fit the window+stretchWith :: Dimension -> Picture -> Window ()+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)+    return ()++stretch :: Picture -> Window ()+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+    screen <- Reader.ask+    let (ax,ay) = align a dim screen+    let pic' = translateX ax $ translateY ay pic+    let region' pos = region $ translatePointX (-ax) $ translatePointY (-ay) pos+    Writer.tell (pic',region')++fitWith :: Dimension -> WindowOutput -> Window ()+fitWith (cx,cy) (pic,region) = Window $ do+    (sx,sy) <- Reader.ask+    let scalex = sx / cx+    let scaley = sy / cy+    let scalexy = max 0 (min scalex scaley)+    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)++largestAspectFit :: Float -> Float -> Dimension -> Dimension+largestAspectFit a b (screenW,screenH)+  | screenW / screenH >= a / b = (screenH * (a / b), screenH)+  | otherwise                  = (screenW, screenW * (b / a))++text :: String -> Window ()+text str = fitWith dim (pic,mempty)+    where+    textWidth = realToFrac (length str) * (realToFrac charWidth)+    pic = Translate (-realToFrac textWidth/2) (-realToFrac charHeight/2) $ Text str+    dim = (textWidth,realToFrac charHeight)++-- * Regions++-- | Registers a new region for the current window+addRegion :: String -> Window ()+addRegion name = do+    dim <- askDimension+    let reg = dimensionToRegion dim+    tellWindowOutput (Blank,\p -> if pointInsideRegion p reg then Set.singleton name else Set.empty)++-- * Alignment types++-- | 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)++-- | 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)++