diff --git a/Graphics/Gloss.hs b/Graphics/Gloss.hs --- a/Graphics/Gloss.hs +++ b/Graphics/Gloss.hs @@ -1,31 +1,46 @@ -- | Gloss hides the pain of drawing simple vector graphics behind a nice data type and --- a few display functions. +-- a few display functions. -- -- Getting something on the screen is as easy as: -- -- @ --- import Graphics.Gloss --- main = `display` (InWindow \"Nice Window\" (200, 200) (10, 10)) `white` (`Circle` 80) +-- import Graphics.Gloss +-- main = `display` (InWindow \"Nice Window\" (200, 200) (10, 10)) `white` (`Circle` 80) -- @ -- -- Once the window is open you can use the following: -- --- * Quit - esc-key. +-- @ +-- * Quit +-- - esc-key -- --- * Move Viewport - left-click drag, arrow keys. +-- * Move Viewport +-- - arrow keys +-- - left-click drag -- --- * Rotate Viewport - right-click drag, control-left-click drag, or home\/end-keys. +-- * Zoom Viewport +-- - page up/down-keys +-- - control-left-click drag +-- - right-click drag +-- - mouse wheel -- --- * Zoom Viewport - mouse wheel, or page up\/down-keys. +-- * Rotate Viewport +-- - home/end-keys +-- - alt-left-click drag -- +-- * Reset Viewport +-- 'r'-key +-- @ +-- +-- -- Animations can be constructed similarly using the `animate`. -- -- If you want to run a simulation based around finite time steps then try -- `simulate`. -- -- If you want to manage your own key\/mouse events then use `play`. --- +-- -- Gloss uses OpenGL under the hood, but you don't have to worry about any of that. -- -- Gloss programs should be compiled with @-threaded@, otherwise the GHC runtime @@ -34,45 +49,58 @@ -- To build gloss using the GLFW window manager instead of GLUT use -- @cabal install gloss --flags=\"GLFW -GLUT\"@ -- --- @Release Notes: +-- @ +-- Release Notes: -- --- For 1.8.0 --- Thanks to Francesco Mazzoli --- * Factored out ViewPort and ViewState handling into user visible modules. +-- For 1.13.1: +-- Thanks to Thaler Jonathan +-- * Repaired GLFW backend. +-- Thanks to Samuel Gfrörer +-- * Support for bitmap sections. +-- Thanks to Basile Henry +-- * Handle resize events in playField driver. -- --- For 1.7.0: --- * Tweaked circle level-of-detail reduction code. --- * Increased frame rate cap to 100hz. --- Thanks to Doug Burke --- * Primitives for drawing arcs and sectors. --- Thanks to Thomas DuBuisson --- * IO versions of animate, simplate and play. +-- For 1.12.1: +-- Thanks to Trevor McDonell +-- * Travis CI integration, general cleanups. -- --- For 1.6.0: --- Thanks to Anthony Cowley --- * Full screen display mode. --- --- For 1.5.0: --- * O(1) Conversion of ForeignPtrs to bitmaps. --- * An extra flag on the Bitmap constructor allows bitmaps to be cached --- in texture memory between frames. +-- For 1.11.1: +-- Thanks to Lars Wyssard +-- * Use default display resolution in full-screen mode. +-- +-- For 1.10.1: +-- * Gloss no longer consumes CPU time when displaying static pictures. +-- * Added displayIO wrapper for mostly static pictures, eg when +-- plotting graphs generated from infrequently updated files. +-- * Allow viewport to be scaled with control-left-click drag. +-- * Rotation of viewport changed to alt-left-click drag. +-- * Preserve current colour when rendering bitmpaps. +-- * Changed to proper sum-of-squares colour mixing, rather than naive +-- addition of components which was causing mixed colours to be too dark. +-- Thanks to Thomas DuBuisson +-- * Allow bitmaps to be specified in RGBA byte order as well as ABGR. +-- Thanks to Gabriel Gonzalez +-- * Package definitions for building with Stack. -- @ -- -- For more information, check out . -- -module Graphics.Gloss - ( module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color +module Graphics.Gloss + ( module Graphics.Gloss.Data.Picture + , module Graphics.Gloss.Data.Color + , module Graphics.Gloss.Data.Bitmap , Display(..) - , display - , animate + , display + , animate , simulate - , play) + , play) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color +import Graphics.Gloss.Data.Bitmap import Graphics.Gloss.Interface.Pure.Display import Graphics.Gloss.Interface.Pure.Animate import Graphics.Gloss.Interface.Pure.Simulate import Graphics.Gloss.Interface.Pure.Game + diff --git a/Graphics/Gloss/Algorithms/RayCast.hs b/Graphics/Gloss/Algorithms/RayCast.hs deleted file mode 100644 --- a/Graphics/Gloss/Algorithms/RayCast.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE PatternGuards, RankNTypes #-} - --- | Various ray casting algorithms. -module Graphics.Gloss.Algorithms.RayCast - ( castSegIntoCellularQuadTree - , traceSegIntoCellularQuadTree) -where -import Graphics.Gloss.Data.Picture -import Graphics.Gloss.Data.Quad -import Graphics.Gloss.Data.Extent -import Graphics.Gloss.Data.QuadTree -import Data.List -import Data.Function - - --- | The quadtree contains cells of unit extent (NetHack style). --- Given a line segement (P1-P2) through the tree, get the cell --- closest to P1 that intersects the segment, if any. --- --- TODO: This currently uses a naive algorithm. It just calls --- `traceSegIntoCellularQuadTree` and sorts the results --- to get the one closest to P1. It'd be better to do a --- proper walk over the tree in the direction of the ray. --- -castSegIntoCellularQuadTree - :: forall a - . Point -- ^ (P1) Starting point of seg. - -> Point -- ^ (P2) Final point of seg. - -> Extent -- ^ Extent convering the whole tree. - -> QuadTree a -- ^ The tree. - -> Maybe (Point, Extent, a) -- ^ Intersection point, extent of cell, value of cell (if any). - -castSegIntoCellularQuadTree p1 p2 extent tree - | cells@(_:_) <- traceSegIntoCellularQuadTree p1 p2 extent tree - , c : _ <- sortBy ((compareDistanceTo p1) `on` (\(a, _, _) -> a) ) cells - = Just c - - | otherwise - = Nothing - -compareDistanceTo :: Point -> Point -> Point -> Ordering -compareDistanceTo p0 p1 p2 - = let d1 = distance p0 p1 - d2 = distance p0 p2 - in compare d1 d2 - -distance :: Point -> Point -> Float -distance (x1, y1) (x2, y2) - = let xd = x2 - x1 - yd = y2 - y1 - in sqrt (xd * xd + yd * yd) - - --- | The quadtree contains cells of unit extent (NetHack style). --- Given a line segment (P1-P2) through the tree, return the list of cells --- that intersect the segment. --- -traceSegIntoCellularQuadTree - :: forall a - . Point -- ^ (P1) Starting point of seg. - -> Point -- ^ (P2) Final point of seg. - -> Extent -- ^ Extent covering the whole tree. - -> QuadTree a -- ^ The tree. - -> [(Point, Extent, a)] -- ^ Intersection point, extent of cell, value of cell. - -traceSegIntoCellularQuadTree p1 p2 extent tree - = case tree of - TNil -> [] - TLeaf a - -> case intersectSegExtent p1 p2 extent of - Just pos -> [(pos, extent, a)] - Nothing -> [] - - TNode nw ne sw se - | touchesSegExtent p1 p2 extent - -> concat - [ traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent NW extent) nw - , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent NE extent) ne - , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent SW extent) sw - , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent SE extent) se ] - - _ -> [] diff --git a/Graphics/Gloss/Data/Bitmap.hs b/Graphics/Gloss/Data/Bitmap.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Data/Bitmap.hs @@ -0,0 +1,16 @@ + +-- | Functions to load bitmap data from various places. +module Graphics.Gloss.Data.Bitmap + ( Rectangle(..) + , BitmapData, bitmapSize + , BitmapFormat(..), RowOrder(..), PixelFormat(..) + , bitmapOfForeignPtr + , bitmapDataOfForeignPtr + , bitmapOfByteString + , bitmapDataOfByteString + , bitmapOfBMP + , bitmapDataOfBMP + , loadBMP) +where +import Graphics.Gloss.Rendering + diff --git a/Graphics/Gloss/Data/Color.hs b/Graphics/Gloss/Data/Color.hs --- a/Graphics/Gloss/Data/Color.hs +++ b/Graphics/Gloss/Data/Color.hs @@ -1,237 +1,180 @@ -- | Predefined and custom colors. module Graphics.Gloss.Data.Color - ( - -- ** Color data type - Color - , makeColor - , makeColor' - , makeColor8 - , rawColor - , rgbaOfColor + ( -- ** Color data type + Color + , makeColor + , makeColorI + , rgbaOfColor - -- ** Color functions - , mixColors - , addColors - , dim, bright - , light, dark + -- ** Color functions + , mixColors + , addColors + , dim, bright + , light, dark - -- ** Pre-defined colors - , greyN, black, white - -- *** Primary - , red, green, blue - -- *** Secondary - , yellow, cyan, magenta - - -- *** Tertiary - , rose, violet, azure, aquamarine, chartreuse, orange - ) -where -import Data.Data + , withRed + , withGreen + , withBlue + , withAlpha + -- ** Pre-defined colors + , greyN, black, white --- | An abstract color value. --- We keep the type abstract so we can be sure that the components --- are in the required range. To make a custom color use 'makeColor'. -data Color - -- | Holds the color components. All components lie in the range [0..1. - = RGBA !Float !Float !Float !Float - deriving (Show, Eq, Data, Typeable) + -- *** Primary + , red, green, blue + -- *** Secondary + , yellow, cyan, magenta -instance Num Color where - {-# INLINE (+) #-} - (+) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) - = RGBA (r1 + r2) (g1 + g2) (b1 + b2) 1 + -- *** Tertiary + , rose, violet, azure, aquamarine, chartreuse, orange + ) +where +import Graphics.Gloss.Rendering - {-# INLINE (-) #-} - (-) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) - = RGBA (r1 - r2) (g1 - g2) (b1 - b2) 1 - {-# INLINE (*) #-} - (*) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) - = RGBA (r1 * r2) (g1 * g2) (b1 * b2) 1 - {-# INLINE abs #-} - abs (RGBA r1 g1 b1 _) - = RGBA (abs r1) (abs g1) (abs b1) 1 - - {-# INLINE signum #-} - signum (RGBA r1 g1 b1 _) - = RGBA (signum r1) (signum g1) (signum b1) 1 - - {-# INLINE fromInteger #-} - fromInteger i - = let f = fromInteger i - in RGBA f f f 1 - - --- | Make a custom color. All components are clamped to the range [0..1]. -makeColor - :: Float -- ^ Red component. - -> Float -- ^ Green component. - -> Float -- ^ Blue component. - -> Float -- ^ Alpha component. - -> Color - -makeColor r g b a - = clampColor - $ RGBA r g b a -{-# INLINE makeColor #-} - - --- | Make a custom color. --- You promise that all components are clamped to the range [0..1] -makeColor' :: Float -> Float -> Float -> Float -> Color -makeColor' r g b a - = RGBA r g b a -{-# INLINE makeColor' #-} - - --- | Make a custom color. All components are clamped to the range [0..255]. -makeColor8 - :: Int -- ^ Red component. - -> Int -- ^ Green component. - -> Int -- ^ Blue component. - -> Int -- ^ Alpha component. - -> Color - -makeColor8 r g b a - = clampColor - $ RGBA (fromIntegral r / 255) - (fromIntegral g / 255) - (fromIntegral b / 255) - (fromIntegral a / 255) -{-# INLINE makeColor8 #-} - - --- | Take the RGBA components of a color. -rgbaOfColor :: Color -> (Float, Float, Float, Float) -rgbaOfColor (RGBA r g b a) = (r, g, b, a) -{-# INLINE rgbaOfColor #-} - - --- | Make a custom color. --- Components should be in the range [0..1] but this is not checked. -rawColor - :: Float -- ^ Red component. - -> Float -- ^ Green component. - -> Float -- ^ Blue component. - -> Float -- ^ Alpha component. - -> Color - -rawColor = RGBA -{-# INLINE rawColor #-} - - --- Internal - --- | Clamp components of a color into the required range. -clampColor :: Color -> Color -clampColor cc - = let (r, g, b, a) = rgbaOfColor cc - in RGBA (min 1 r) (min 1 g) (min 1 b) (min 1 a) - --- | Normalise a color to the value of its largest RGB component. -normaliseColor :: Color -> Color -normaliseColor cc - = let (r, g, b, a) = rgbaOfColor cc - m = maximum [r, g, b] - in RGBA (r / m) (g / m) (b / m) a - - -- Color functions ------------------------------------------------------------ - -- | Mix two colors with the given ratios. -mixColors - :: Float -- ^ Ratio of first color. - -> Float -- ^ Ratio of second color. - -> Color -- ^ First color. - -> Color -- ^ Second color. - -> Color -- ^ Resulting color. +mixColors + :: Float -- ^ Proportion of first color. + -> Float -- ^ Proportion of second color. + -> Color -- ^ First color. + -> Color -- ^ Second color. + -> Color -- ^ Resulting color. -mixColors ratio1 ratio2 c1 c2 - = let RGBA r1 g1 b1 a1 = c1 - RGBA r2 g2 b2 a2 = c2 +mixColors m1 m2 c1 c2 + = let (r1, g1, b1, a1) = rgbaOfColor c1 + (r2, g2, b2, a2) = rgbaOfColor c2 - total = ratio1 + ratio2 - m1 = ratio1 / total - m2 = ratio2 / total + -- Normalise mixing proportions to ratios. + m12 = m1 + m2 + m1' = m1 / m12 + m2' = m2 / m12 - in RGBA (m1 * r1 + m2 * r2) - (m1 * g1 + m2 * g2) - (m1 * b1 + m2 * b2) - (m1 * a1 + m2 * a2) + -- Colors components should be added via sum of squares, + -- otherwise the result will be too dark. + r1s = r1 * r1; r2s = r2 * r2 + g1s = g1 * g1; g2s = g2 * g2 + b1s = b1 * b1; b2s = b2 * b2 + in makeColor + (sqrt (m1' * r1s + m2' * r2s)) + (sqrt (m1' * g1s + m2' * g2s)) + (sqrt (m1' * b1s + m2' * b2s)) + ((m1 * a1 + m2 * a2) / m12) --- | Add RGB components of a color component-wise, then normalise --- them to the highest resulting one. The alpha components are averaged. + +-- | Add RGB components of a color component-wise, +-- then normalise them to the highest resulting one. +-- The alpha components are averaged. addColors :: Color -> Color -> Color addColors c1 c2 - = let RGBA r1 g1 b1 a1 = c1 - RGBA r2 g2 b2 a2 = c2 + = let (r1, g1, b1, a1) = rgbaOfColor c1 + (r2, g2, b2, a2) = rgbaOfColor c2 - in normaliseColor - $ RGBA (r1 + r2) - (g1 + g2) - (b1 + b2) - ((a1 + a2) / 2) + in normalizeColor + (r1 + r2) + (g1 + g2) + (b1 + b2) + ((a1 + a2) / 2) -- | Make a dimmer version of a color, scaling towards black. dim :: Color -> Color -dim (RGBA r g b a) - = RGBA (r / 1.2) (g / 1.2) (b / 1.2) a +dim c + = let (r, g, b, a) = rgbaOfColor c + in makeColor (r / 1.2) (g / 1.2) (b / 1.2) a - + -- | Make a brighter version of a color, scaling towards white. bright :: Color -> Color -bright (RGBA r g b a) - = clampColor - $ RGBA (r * 1.2) (g * 1.2) (b * 1.2) a +bright c + = let (r, g, b, a) = rgbaOfColor c + in makeColor (r * 1.2) (g * 1.2) (b * 1.2) a -- | Lighten a color, adding white. light :: Color -> Color -light (RGBA r g b a) - = clampColor - $ RGBA (r + 0.2) (g + 0.2) (b + 0.2) a - - +light c + = let (r, g, b, a) = rgbaOfColor c + in makeColor (r + 0.2) (g + 0.2) (b + 0.2) a + + -- | Darken a color, adding black. dark :: Color -> Color -dark (RGBA r g b a) - = clampColor - $ RGBA (r - 0.2) (g - 0.2) (b - 0.2) a +dark c + = let (r, g, b, a) = rgbaOfColor c + in makeColor (r - 0.2) (g - 0.2) (b - 0.2) a +------------------------------------------------------------------------------- +-- | Set the red value of a `Color`. +withRed :: Float -> Color -> Color +withRed r c + = let (_, g, b, a) = rgbaOfColor c + in makeColor r g b a + + +-- | Set the green value of a `Color`. +withGreen :: Float -> Color -> Color +withGreen g c + = let (r, _, b, a) = rgbaOfColor c + in makeColor r g b a + + +-- | Set the blue value of a `Color`. +withBlue :: Float -> Color -> Color +withBlue b c + = let (r, g, _, a) = rgbaOfColor c + in makeColor r g b a + + +-- | Set the alpha value of a `Color`. +withAlpha :: Float -> Color -> Color +withAlpha a c + = let (r, g, b, _) = rgbaOfColor c + in makeColor r g b a + + -- Pre-defined Colors --------------------------------------------------------- --- | A greyness of a given magnitude. -greyN :: Float -- ^ Range is 0 = black, to 1 = white. - -> Color -greyN n = RGBA n n n 1.0 +-- | A greyness of a given order. +-- +-- Range is 0 = black, to 1 = white. +greyN :: Float -> Color +greyN n = makeRawColor n n n 1.0 black, white :: Color -black = RGBA 0.0 0.0 0.0 1.0 -white = RGBA 1.0 1.0 1.0 1.0 +black = makeRawColor 0.0 0.0 0.0 1.0 +white = makeRawColor 1.0 1.0 1.0 1.0 -- Colors from the additive color wheel. red, green, blue :: Color -red = RGBA 1.0 0.0 0.0 1.0 -green = RGBA 0.0 1.0 0.0 1.0 -blue = RGBA 0.0 0.0 1.0 1.0 +red = makeRawColor 1.0 0.0 0.0 1.0 +green = makeRawColor 0.0 1.0 0.0 1.0 +blue = makeRawColor 0.0 0.0 1.0 1.0 -- secondary yellow, cyan, magenta :: Color -yellow = addColors red green -cyan = addColors green blue -magenta = addColors red blue +yellow = addColors red green +cyan = addColors green blue +magenta = addColors red blue -- tertiary rose, violet, azure, aquamarine, chartreuse, orange :: Color -rose = addColors red magenta -violet = addColors magenta blue -azure = addColors blue cyan -aquamarine = addColors cyan green -chartreuse = addColors green yellow -orange = addColors yellow red +rose = addColors red magenta +violet = addColors magenta blue +azure = addColors blue cyan +aquamarine = addColors cyan green +chartreuse = addColors green yellow +orange = addColors yellow red + + +------------------------------------------------------------------------------- +-- | Normalise a color to the value of its largest RGB component. +normalizeColor :: Float -> Float -> Float -> Float -> Color +normalizeColor r g b a + = let m = maximum [r, g, b] + in makeColor (r / m) (g / m) (b / m) a + diff --git a/Graphics/Gloss/Data/Controller.hs b/Graphics/Gloss/Data/Controller.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Data/Controller.hs @@ -0,0 +1,15 @@ + +module Graphics.Gloss.Data.Controller + ( Controller (..)) +where +import Graphics.Gloss.Data.ViewPort + + +-- | Functions to asynchronously control a `Gloss` display. +data Controller + = Controller + { -- | Indicate that we want the picture to be redrawn. + controllerSetRedraw :: IO () + + -- | Modify the current viewport, also indicating that it should be redrawn. + , controllerModifyViewPort :: (ViewPort -> IO ViewPort) -> IO () } diff --git a/Graphics/Gloss/Data/Display.hs b/Graphics/Gloss/Data/Display.hs --- a/Graphics/Gloss/Data/Display.hs +++ b/Graphics/Gloss/Data/Display.hs @@ -8,6 +8,6 @@ -- | Display in a window with the given name, size and position. = InWindow String (Int, Int) (Int, Int) - -- | Display full screen with a drawing area of the given size. - | FullScreen (Int, Int) + -- | Display full screen. + | FullScreen deriving (Eq, Read, Show) diff --git a/Graphics/Gloss/Data/Extent.hs b/Graphics/Gloss/Data/Extent.hs deleted file mode 100644 --- a/Graphics/Gloss/Data/Extent.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE PatternGuards #-} - --- | Represents an integral rectangular area of the 2D plane. --- Using `Int`s (instead of `Float`s) for the bounds means we can safely --- compare extents for equality. -module Graphics.Gloss.Data.Extent - ( Extent - , Coord - , makeExtent - , takeExtent - , squareExtent - , sizeOfExtent - , isUnitExtent - , coordInExtent - , pointInExtent - , centerCoordOfExtent - , cutQuadOfExtent - , quadOfCoord - , pathToCoord - , intersectSegExtent - , touchesSegExtent) -where -import Graphics.Gloss.Data.Point -import Graphics.Gloss.Data.Quad -import Graphics.Gloss.Geometry.Line -import Data.Maybe - - --- | A rectangular area of the 2D plane. --- We keep the type abstract to ensure that invalid extents cannot be --- constructed. -data Extent - = Extent Int Int Int Int - deriving (Eq, Show) - - --- | An integral coordinate. -type Coord - = (Int, Int) - - --- | Construct an extent. --- The north value must be > south, and east > west, else `error`. -makeExtent - :: Int -- ^ y max (north) - -> Int -- ^ y min (south) - -> Int -- ^ x max (east) - -> Int -- ^ x min (west) - -> Extent - -makeExtent n s e w - | n >= s, e >= w - = Extent n s e w - - | otherwise - = error "Graphics.Gloss.Geometry.Extent.makeExtent: invalid extent" - - --- | Take the NSEW components of an extent. -takeExtent :: Extent -> (Int, Int, Int, Int) -takeExtent (Extent n s e w) - = (n, s, e, w) - - --- | A square extent of a given size. -squareExtent :: Int -> Extent -squareExtent i - = Extent i 0 i 0 - - --- | Get the width and height of an extent. -sizeOfExtent :: Extent -> (Int, Int) -sizeOfExtent (Extent n s e w) - = (e - w, n - s) - - --- | Check if an extent is a square with a width and height of 1. -isUnitExtent :: Extent -> Bool -isUnitExtent extent - = sizeOfExtent extent == (1, 1) - - --- | Check whether a coordinate lies inside an extent. -coordInExtent :: Extent -> Coord -> Bool -coordInExtent (Extent n s e w) (x, y) - = x >= w && x < e - && y >= s && y < n - - --- | Check whether a point lies inside an extent. -pointInExtent :: Extent -> Point -> Bool -pointInExtent (Extent n s e w) (x, y) - = let n' = fromIntegral n - s' = fromIntegral s - e' = fromIntegral e - w' = fromIntegral w - - in x >= w' && x <= e' - && y >= s' && y <= n' - - --- | Get the coordinate that lies at the center of an extent. -centerCoordOfExtent :: Extent -> (Int, Int) -centerCoordOfExtent (Extent n s e w) - = ( w + (e - w) `div` 2 - , s + (n - s) `div` 2) - - --- | Cut one quadrant out of an extent. -cutQuadOfExtent :: Quad -> Extent -> Extent -cutQuadOfExtent quad (Extent n s e w) - = let hheight = (n - s) `div` 2 - hwidth = (e - w) `div` 2 - in case quad of - NW -> Extent n (s + hheight) (e - hwidth) w - NE -> Extent n (s + hheight) e (w + hwidth) - SW -> Extent (n - hheight) s (e - hwidth) w - SE -> Extent (n - hheight) s e (w + hwidth) - - --- | Get the quadrant that this coordinate lies in, if any. -quadOfCoord :: Extent -> Coord -> Maybe Quad -quadOfCoord extent coord - = listToMaybe - $ filter (\q -> coordInExtent (cutQuadOfExtent q extent) coord) - $ allQuads - - --- | Constuct a path to a particular coordinate in an extent. -pathToCoord :: Extent -> Coord -> Maybe [Quad] -pathToCoord extent coord - | isUnitExtent extent - = Just [] - - | otherwise - = do quad <- quadOfCoord extent coord - rest <- pathToCoord (cutQuadOfExtent quad extent) coord - return $ quad : rest - - --- | If a line segment (P1-P2) intersects the outer edge of an extent then --- return the intersection point, that is closest to P1, if any. --- If P1 is inside the extent then `Nothing`. --- --- @ --- P2 --- / --- ----/- --- | / | --- + | --- /------ --- / --- P1 --- @ --- -intersectSegExtent :: Point -> Point -> Extent -> Maybe Point -intersectSegExtent p1@(x1, y1) p2 (Extent n' s' e' w') - -- starts below extent - | y1 < s - , Just pos <- intersectSegHorzSeg p1 p2 s w e - = Just pos - - -- starts above extent - | y1 > n - , Just pos <- intersectSegHorzSeg p1 p2 n w e - = Just pos - - -- starts left of extent - | x1 < w - , Just pos <- intersectSegVertSeg p1 p2 w s n - = Just pos - - -- starts right of extent - | x1 > e - , Just pos <- intersectSegVertSeg p1 p2 e s n - = Just pos - - -- must be starting inside extent. - | otherwise - = Nothing - - where n = fromIntegral n' - s = fromIntegral s' - e = fromIntegral e' - w = fromIntegral w' - - --- | Check whether a line segment's endpoints are inside an extent, or if it --- intersects with the boundary. -touchesSegExtent :: Point -> Point -> Extent -> Bool -touchesSegExtent p1 p2 extent - = pointInExtent extent p1 - || pointInExtent extent p2 - || isJust (intersectSegExtent p1 p2 extent) - diff --git a/Graphics/Gloss/Data/Picture.hs b/Graphics/Gloss/Data/Picture.hs --- a/Graphics/Gloss/Data/Picture.hs +++ b/Graphics/Gloss/Data/Picture.hs @@ -1,139 +1,44 @@ --- | Data types for representing pictures. module Graphics.Gloss.Data.Picture - ( Point - , Vector - , Path - , Picture(..) - , BitmapData + ( Picture (..) + , Point, Vector, Path - -- * Aliases for Picture constructors - , blank + -- * Aliases for Picture constructors + , blank , polygon , line , circle, thickCircle , arc, thickArc , text , bitmap - , color + , bitmapSection + -- , bitmap + , color , translate, rotate, scale - , pictures + , pictures - -- * Compound shapes - , lineLoop - , circleSolid + -- * Compound shapes + , lineLoop + , circleSolid , arcSolid , sectorWire - , rectanglePath + , rectanglePath , rectangleWire , rectangleSolid - , rectangleUpperPath + , rectangleUpperPath , rectangleUpperWire - , rectangleUpperSolid - - -- * Loading Bitmaps - , bitmapOfForeignPtr - , bitmapOfByteString - , bitmapOfBMP - , loadBMP) - + , rectangleUpperSolid) where -import Graphics.Gloss.Data.Color -import Graphics.Gloss.Data.Point -import Graphics.Gloss.Data.Vector +import Graphics.Gloss.Rendering import Graphics.Gloss.Geometry.Angle -import Graphics.Gloss.Internals.Render.Bitmap -import Codec.BMP -import Foreign.ForeignPtr -import Foreign.Marshal.Alloc -import Foreign.Marshal.Utils -import Foreign.Ptr -import Data.Word -import Data.Monoid -import Data.ByteString -import Data.Data -import System.IO.Unsafe -import qualified Data.ByteString.Unsafe as BSU -import Prelude hiding (map) --- | A path through the x-y plane. -type Path = [Point] - --- | A 2D picture -data Picture - -- Primitives ------------------------------------- - - -- | A blank picture, with nothing in it. - = Blank - - -- | A convex polygon filled with a solid color. - | Polygon Path - - -- | A line along an arbitrary path. - | Line Path - - -- | A circle with the given radius. - | Circle Float - - -- | A circle with the given thickness and radius. - -- If the thickness is 0 then this is equivalent to `Circle`. - | ThickCircle Float Float - - -- | A circular arc drawn counter-clockwise between two angles - -- (in degrees) at the given radius. - | Arc Float Float Float - - -- | A circular arc drawn counter-clockwise between two angles - -- (in degrees), with the given radius and thickness. - -- If the thickness is 0 then this is equivalent to `Arc`. - | ThickArc Float Float Float Float - - -- | Some text to draw with a vector font. - | Text String - - -- | A bitmap image with a width, height and some 32-bit RGBA - -- bitmap data. - -- - -- The boolean flag controls whether Gloss should cache the data - -- between frames for speed. If you are programatically generating - -- the image for each frame then use `False`. If you have loaded it - -- from a file then use `True`. - | Bitmap Int Int BitmapData Bool - - -- Color ------------------------------------------ - -- | A picture drawn with this color. - | Color Color Picture - - -- Transforms ------------------------------------- - -- | A picture translated by the given x and y coordinates. - | Translate Float Float Picture - - -- | A picture rotated clockwise by the given angle (in degrees). - | Rotate Float Picture - - -- | A picture scaled by the given x and y factors. - | Scale Float Float Picture - - -- More Pictures ---------------------------------- - -- | A picture consisting of several others. - | Pictures [Picture] - deriving (Show, Eq, Data, Typeable) - - --- Instances ------------------------------------------------------------------ -instance Monoid Picture where - mempty = blank - mappend a b = Pictures [a, b] - mconcat = Pictures - - -- Constructors ---------------------------------------------------------------- -- NOTE: The docs here should be identical to the ones on the constructors. -- | A blank picture, with nothing in it. blank :: Picture -blank = Blank +blank = Blank -- | A convex polygon filled with a solid color. polygon :: Path -> Picture @@ -141,18 +46,18 @@ -- | A line along an arbitrary path. line :: Path -> Picture -line = Line +line = Line -- | A circle with the given radius. circle :: Float -> Picture -circle = Circle +circle = Circle -- | A circle with the given thickness and radius. -- If the thickness is 0 then this is equivalent to `Circle`. thickCircle :: Float -> Float -> Picture thickCircle = ThickCircle --- | A circular arc drawn counter-clockwise between two angles (in degrees) +-- | A circular arc drawn counter-clockwise between two angles (in degrees) -- at the given radius. arc :: Float -> Float -> Float -> Picture arc = Arc @@ -167,17 +72,16 @@ text :: String -> Picture text = Text --- | A bitmap image with a width, height and a Vector holding the --- 32-bit RGBA bitmap data. --- --- The boolean flag controls whether Gloss should cache the data --- between frames for speed. --- If you are programatically generating the image for --- each frame then use `False`. --- If you have loaded it from a file then use `True`. -bitmap :: Int -> Int -> BitmapData -> Bool -> Picture -bitmap = Bitmap +-- | A bitmap image +bitmap :: BitmapData -> Picture +bitmap bitmapData = Bitmap bitmapData +-- | a subsection of a bitmap image +-- first argument selects a sub section in the bitmap +-- second argument determines the bitmap data +bitmapSection :: Rectangle -> BitmapData -> Picture +bitmapSection = BitmapSection + -- | A picture drawn with this color. color :: Color -> Picture -> Picture color = Color @@ -199,106 +103,39 @@ pictures = Pictures --- Bitmaps -------------------------------------------------------------------- --- | O(1). Use a `ForeignPtr` of RGBA data as a bitmap with the given --- width and height. - --- The boolean flag controls whether Gloss should cache the data --- between frames for speed. If you are programatically generating --- the image for each frame then use `False`. If you have loaded it --- from a file then use `True`. -bitmapOfForeignPtr :: Int -> Int -> ForeignPtr Word8 -> Bool -> Picture -bitmapOfForeignPtr width height fptr cacheMe - = let len = width * height * 4 - bdata = BitmapData len fptr - in Bitmap width height bdata cacheMe - - --- | O(size). Copy a `ByteString` of RGBA data into a bitmap with the given --- width and height. --- --- The boolean flag controls whether Gloss should cache the data --- between frames for speed. If you are programatically generating --- the image for each frame then use `False`. If you have loaded it --- from a file then use `True`. -{-# NOINLINE bitmapOfByteString #-} -bitmapOfByteString :: Int -> Int -> ByteString -> Bool -> Picture -bitmapOfByteString width height bs cacheMe - = unsafePerformIO - $ do let len = width * height * 4 - ptr <- mallocBytes len - fptr <- newForeignPtr finalizerFree ptr - - BSU.unsafeUseAsCString bs - $ \cstr -> copyBytes ptr (castPtr cstr) len - - let bdata = BitmapData len fptr - return $ Bitmap width height bdata cacheMe - - --- | O(size). Copy a `BMP` file into a bitmap. -{-# NOINLINE bitmapOfBMP #-} -bitmapOfBMP :: BMP -> Picture -bitmapOfBMP bmp - = unsafePerformIO - $ do let (width, height) = bmpDimensions bmp - let bs = unpackBMPToRGBA32 bmp - let len = width * height * 4 - - ptr <- mallocBytes len - fptr <- newForeignPtr finalizerFree ptr - - BSU.unsafeUseAsCString bs - $ \cstr -> copyBytes ptr (castPtr cstr) len - - let bdata = BitmapData len fptr - reverseRGBA bdata - - return $ Bitmap width height bdata True - - --- | Load an uncompressed 24 or 32bit RGBA BMP file as a bitmap. -loadBMP :: FilePath -> IO Picture -loadBMP filePath - = do ebmp <- readBMP filePath - case ebmp of - Left err -> error $ show err - Right bmp -> return $ bitmapOfBMP bmp - - -- Other Shapes --------------------------------------------------------------- -- | A closed loop along a path. lineLoop :: Path -> Picture -lineLoop [] = Line [] -lineLoop (x:xs) = Line ((x:xs) ++ [x]) +lineLoop [] = Line [] +lineLoop (x:xs) = Line ((x:xs) ++ [x]) -- Circles and Arcs ----------------------------------------------------------- -- | A solid circle with the given radius. circleSolid :: Float -> Picture -circleSolid r +circleSolid r = thickCircle (r/2) r --- | A solid arc, drawn counter-clockwise between two angles at the given radius. +-- | A solid arc, drawn counter-clockwise between two angles (in degrees) at the given radius. arcSolid :: Float -> Float -> Float -> Picture -arcSolid a1 a2 r - = thickArc a1 a2 (r/2) r +arcSolid a1 a2 r + = thickArc a1 a2 (r/2) r --- | A wireframe sector of a circle. --- An arc is draw counter-clockwise from the first to the second angle at +-- | A wireframe sector of a circle. +-- An arc is draw counter-clockwise from the first to the second angle (in degrees) at -- the given radius. Lines are drawn from the origin to the ends of the arc. --- -- NOTE: We take the absolute value of the radius incase it's negative. --- It would also make sense to draw the sector flipped around the +-- It would also make sense to draw the sector flipped around the -- origin, but I think taking the absolute value will be less surprising -- for the user. --- +-- sectorWire :: Float -> Float -> Float -> Picture sectorWire a1 a2 r_ = let r = abs r_ - in Pictures + in Pictures [ Arc a1 a2 r , Line [(0, 0), (r * cos (degToRad a1), r * sin (degToRad a1))] , Line [(0, 0), (r * cos (degToRad a2), r * sin (degToRad a2))] ] @@ -309,43 +146,43 @@ -- arguments to reduce the amount of noise in the extracted docs. -- | A path representing a rectangle centered about the origin -rectanglePath +rectanglePath :: Float -- ^ width of rectangle -> Float -- ^ height of rectangle -> Path -rectanglePath sizeX sizeY - = let sx = sizeX / 2 - sy = sizeY / 2 - in [(-sx, -sy), (-sx, sy), (sx, sy), (sx, -sy)] +rectanglePath sizeX sizeY + = let sx = sizeX / 2 + sy = sizeY / 2 + in [(-sx, -sy), (-sx, sy), (sx, sy), (sx, -sy)] -- | A wireframe rectangle centered about the origin. rectangleWire :: Float -> Float -> Picture rectangleWire sizeX sizeY - = lineLoop $ rectanglePath sizeX sizeY + = lineLoop $ rectanglePath sizeX sizeY -- | A wireframe rectangle in the y > 0 half of the x-y plane. rectangleUpperWire :: Float -> Float -> Picture rectangleUpperWire sizeX sizeY - = lineLoop $ rectangleUpperPath sizeX sizeY + = lineLoop $ rectangleUpperPath sizeX sizeY -- | A path representing a rectangle in the y > 0 half of the x-y plane. rectangleUpperPath :: Float -> Float -> Path rectangleUpperPath sizeX sy - = let sx = sizeX / 2 - in [(-sx, 0), (-sx, sy), (sx, sy), (sx, 0)] + = let sx = sizeX / 2 + in [(-sx, 0), (-sx, sy), (sx, sy), (sx, 0)] -- | A solid rectangle centered about the origin. rectangleSolid :: Float -> Float -> Picture rectangleSolid sizeX sizeY - = Polygon $ rectanglePath sizeX sizeY + = Polygon $ rectanglePath sizeX sizeY -- | A solid rectangle in the y > 0 half of the x-y plane. rectangleUpperSolid :: Float -> Float -> Picture rectangleUpperSolid sizeX sizeY - = Polygon $ rectangleUpperPath sizeX sizeY + = Polygon $ rectangleUpperPath sizeX sizeY diff --git a/Graphics/Gloss/Data/Point.hs b/Graphics/Gloss/Data/Point.hs --- a/Graphics/Gloss/Data/Point.hs +++ b/Graphics/Gloss/Data/Point.hs @@ -1,30 +1,8 @@ -{-# OPTIONS -fno-warn-missing-methods -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Graphics.Gloss.Data.Point - ( Point - , pointInBox) + ( Point, Path + , pointInBox) where - --- | A point on the x-y plane. --- Points can also be treated as `Vector`s, so "Graphics.Gloss.Data.Vector" --- may also be useful. -type Point = (Float, Float) - - --- | Pretend a point is a number. --- Vectors aren't real numbes according to Haskell, because they don't --- support the multiply and divide field operators. We can pretend they --- are though, and use the (+) and (-) operators as component-wise --- addition and subtraction. --- -instance Num Point where - (+) (x1, y1) (x2, y2) = (x1 + x2, y1 + y2) - (-) (x1, y1) (x2, y2) = (x1 - x2, y1 - y2) - (*) (x1, y1) (x2, y2) = (x1 * x2, y1 * y2) - signum (x, y) = (signum x, signum y) - abs (x, y) = (abs x, abs y) - negate (x, y) = (negate x, negate y) - fromInteger x = (fromInteger x, fromInteger x) +import Graphics.Gloss.Data.Picture -- | Test whether a point lies within a rectangular box that is oriented @@ -39,13 +17,13 @@ -- +-------+ P1 -- @ -- -pointInBox - :: Point - -> Point - -> Point -> Bool - +pointInBox + :: Point + -> Point + -> Point -> Bool + pointInBox (x0, y0) (x1, y1) (x2, y2) - = x0 >= min x1 x2 - && x0 <= max x1 x2 - && y0 >= min y1 y2 - && y0 <= max y1 y2 + = x0 >= min x1 x2 + && x0 <= max x1 x2 + && y0 >= min y1 y2 + && y0 <= max y1 y2 diff --git a/Graphics/Gloss/Data/Point/Arithmetic.hs b/Graphics/Gloss/Data/Point/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Data/Point/Arithmetic.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE BangPatterns #-} + +-- | +-- == Point and vector arithmetic +-- +-- Vectors aren't numbers according to Haskell, because they don't +-- support all numeric operations sensibly. We define component-wise +-- addition, subtraction, and negation along with scalar multiplication +-- in this module, which is intended to be imported qualified. +module Graphics.Gloss.Data.Point.Arithmetic + ( + Point + , (+) + , (-) + , (*) + , negate + ) where +import Prelude (Float) +import qualified Prelude as P +import Graphics.Gloss.Rendering (Point) + +infixl 6 +, - +infixl 7 * + +-- | Add two vectors, or add a vector to a point. +(+) :: Point -> Point -> Point +(x1, y1) + (x2, y2) = + let + !x = x1 P.+ x2 + !y = y1 P.+ y2 + in (x, y) + +-- | Subtract two vectors, or subtract a vector from a point. +(-) :: Point -> Point -> Point +(x1, y1) - (x2, y2) = + let + !x = x1 P.- x2 + !y = y1 P.- y2 + in (x, y) + +-- | Negate a vector. +negate :: Point -> Point +negate (x, y) = + let + !x' = P.negate x + !y' = P.negate y + in (x', y') + +-- | Multiply a scalar by a vector. +(*) :: Float -> Point -> Point +(*) s (x, y) = + let + !x' = s P.* x + !y' = s P.* y + in (x', y') diff --git a/Graphics/Gloss/Data/Quad.hs b/Graphics/Gloss/Data/Quad.hs deleted file mode 100644 --- a/Graphics/Gloss/Data/Quad.hs +++ /dev/null @@ -1,17 +0,0 @@ - -module Graphics.Gloss.Data.Quad - ( Quad(..) - , allQuads) -where - --- | Represents a Quadrant in the 2D plane. -data Quad - = NW -- ^ North West - | NE -- ^ North East - | SW -- ^ South West - | SE -- ^ South East - deriving (Show, Eq, Enum) - --- | A list of all quadrants. Same as @[NW .. SE]@. -allQuads :: [Quad] -allQuads = [NW .. SE] diff --git a/Graphics/Gloss/Data/QuadTree.hs b/Graphics/Gloss/Data/QuadTree.hs deleted file mode 100644 --- a/Graphics/Gloss/Data/QuadTree.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - --- | A QuadTree can be used to recursively divide up 2D space into quadrants. --- The smallest division corresponds to an unit `Extent`, so the total depth --- of the tree will depend on what sized `Extent` you start with. -module Graphics.Gloss.Data.QuadTree - ( QuadTree (..) - , emptyTree - , emptyNode - , takeQuadOfTree - , liftToQuad - , insertByPath - , insertByCoord - , lookupNodeByPath - , lookupByPath - , lookupByCoord - , flattenQuadTree - , flattenQuadTreeWithExtents) -where -import Graphics.Gloss.Data.Quad -import Graphics.Gloss.Data.Extent - --- | The quad tree structure. -data QuadTree a - -- | An empty node. - = TNil - - -- | A leaf containint some value. - | TLeaf a - - -- | A node with four children. - | TNode (QuadTree a) (QuadTree a) -- NW NE - (QuadTree a) (QuadTree a) -- SW SE - deriving Show - - --- | A `TNil` tree. -emptyTree :: QuadTree a -emptyTree = TNil - - --- | A node with `TNil`. for all its branches. -emptyNode :: QuadTree a -emptyNode = TNode TNil TNil TNil TNil - - --- | Get a quadrant from a node. --- If the tree does not have an outer node then `Nothing`. -takeQuadOfTree - :: Quad - -> QuadTree a - -> Maybe (QuadTree a) - -takeQuadOfTree quad tree - = case tree of - TNil -> Nothing - TLeaf{} -> Nothing - TNode nw ne sw se - -> case quad of - NW -> Just nw - NE -> Just ne - SW -> Just sw - SE -> Just se - - --- | Apply a function to a quadrant of a node. --- If the tree does not have an outer node then return the original tree. -liftToQuad - :: Quad - -> (QuadTree a -> QuadTree a) - -> QuadTree a -> QuadTree a - -liftToQuad quad f tree - = case tree of - TNil -> tree - TLeaf{} -> tree - TNode nw ne sw se - -> case quad of - NW -> TNode (f nw) ne sw se - NE -> TNode nw (f ne) sw se - SW -> TNode nw ne (f sw) se - SE -> TNode nw ne sw (f se) - - --- | Insert a value into the tree at the position given by a path. --- If the path intersects an existing `TLeaf` then return the original tree. -insertByPath :: [Quad] -> a -> QuadTree a -> QuadTree a - -insertByPath [] x _ - = TLeaf x - -insertByPath (q:qs) x tree - = case tree of - TNil -> liftToQuad q (insertByPath qs x) emptyNode - TLeaf{} -> tree - TNode{} -> liftToQuad q (insertByPath qs x) tree - - --- | Insert a value into the node containing this coordinate. --- The node is created at maximum depth, corresponding to an unit `Extent`. -insertByCoord :: Extent -> Coord -> a -> QuadTree a -> Maybe (QuadTree a) -insertByCoord extent coord x tree - = do path <- pathToCoord extent coord - return $ insertByPath path x tree - - --- | Lookup a node based on a path to it. -lookupNodeByPath - :: [Quad] - -> QuadTree a - -> Maybe (QuadTree a) - -lookupNodeByPath [] tree - = Just tree - -lookupNodeByPath (q:qs) tree - = case tree of - TNil -> Nothing - TLeaf{} -> Nothing - TNode{} - -> let Just quad = takeQuadOfTree q tree - in lookupNodeByPath qs quad - - --- | Lookup an element based given a path to it. -lookupByPath :: [Quad] -> QuadTree a -> Maybe a -lookupByPath path tree - = case lookupNodeByPath path tree of - Just (TLeaf x) -> Just x - _ -> Nothing - - --- | Lookup a node if a tree given a coordinate which it contains. -lookupByCoord - :: forall a - . Extent -- ^ Extent that covers the whole tree. - -> Coord -- ^ Coordinate of the value of interest. - -> QuadTree a - -> Maybe a -lookupByCoord extent coord tree - = do path <- pathToCoord extent coord - lookupByPath path tree - - --- | Flatten a QuadTree into a list of its contained values, with coordinates. -flattenQuadTree - :: forall a - . Extent -- ^ Extent that covers the whole tree. - -> QuadTree a - -> [(Coord, a)] - -flattenQuadTree extentInit treeInit - = flatten' extentInit treeInit - where flatten' extent tree - = case tree of - TNil -> [] - TLeaf x - -> let (_, s, _, w) = takeExtent extent - in [((w, s), x)] - - TNode{} -> concat $ map (flattenQuad extent tree) allQuads - - flattenQuad extent tree quad - = let extent' = cutQuadOfExtent quad extent - Just tree' = takeQuadOfTree quad tree - in flatten' extent' tree' - - --- | Flatten a QuadTree into a list of its contained values, with coordinates. -flattenQuadTreeWithExtents - :: forall a - . Extent -- ^ Extent that covers the whole tree. - -> QuadTree a - -> [(Extent, a)] - -flattenQuadTreeWithExtents extentInit treeInit - = flatten' extentInit treeInit - where flatten' extent tree - = case tree of - TNil -> [] - TLeaf x - -> [(extent, x)] - - TNode{} -> concat $ map (flattenQuad extent tree) allQuads - - flattenQuad extent tree quad - = let extent' = cutQuadOfExtent quad extent - Just tree' = takeQuadOfTree quad tree - in flatten' extent' tree' - - diff --git a/Graphics/Gloss/Data/Vector.hs b/Graphics/Gloss/Data/Vector.hs --- a/Graphics/Gloss/Data/Vector.hs +++ b/Graphics/Gloss/Data/Vector.hs @@ -3,63 +3,60 @@ -- | Geometric functions concerning vectors. module Graphics.Gloss.Data.Vector - ( Vector - , magV - , argV - , dotV - , detV - , mulSV - , rotateV - , angleVV - , normaliseV - , unitVectorAtAngle ) + ( Vector + , magV + , argV + , dotV + , detV + , mulSV + , rotateV + , angleVV + , normalizeV + , unitVectorAtAngle ) where -import Graphics.Gloss.Data.Point +import Graphics.Gloss.Data.Picture import Graphics.Gloss.Geometry.Angle --- | A vector can be treated as a point, and vis-versa. -type Vector = Point - -- | The magnitude of a vector. magV :: Vector -> Float -magV (x, y) - = sqrt (x * x + y * y) +magV (x, y) + = sqrt (x * x + y * y) {-# INLINE magV #-} -- | The angle of this vector, relative to the +ve x-axis. argV :: Vector -> Float argV (x, y) - = normaliseAngle $ atan2 y x + = normalizeAngle $ atan2 y x {-# INLINE argV #-} -- | The dot product of two vectors. dotV :: Vector -> Vector -> Float dotV (x1, x2) (y1, y2) - = x1 * y1 + x2 * y2 + = x1 * y1 + x2 * y2 {-# INLINE dotV #-} -- | The determinant of two vectors. detV :: Vector -> Vector -> Float detV (x1, y1) (x2, y2) - = x1 * y2 - y1 * x2 + = x1 * y2 - y1 * x2 {-# INLINE detV #-} -- | Multiply a vector by a scalar. mulSV :: Float -> Vector -> Vector -mulSV s (x, y) - = (s * x, s * y) +mulSV s (x, y) + = (s * x, s * y) {-# INLINE mulSV #-} -- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise. rotateV :: Float -> Vector -> Vector rotateV r (x, y) - = ( x * cos r - y * sin r + = ( x * cos r - y * sin r , x * sin r + y * cos r) {-# INLINE rotateV #-} @@ -67,25 +64,25 @@ -- | Compute the inner angle (in radians) between two vectors. angleVV :: Vector -> Vector -> Float angleVV p1 p2 - = let m1 = magV p1 - m2 = magV p2 - d = p1 `dotV` p2 - aDiff = acos $ d / (m1 * m2) + = let m1 = magV p1 + m2 = magV p2 + d = p1 `dotV` p2 + aDiff = acos $ d / (m1 * m2) - in aDiff + in aDiff {-# INLINE angleVV #-} -- | Normalise a vector, so it has a magnitude of 1. -normaliseV :: Vector -> Vector -normaliseV v = mulSV (1 / magV v) v -{-# INLINE normaliseV #-} +normalizeV :: Vector -> Vector +normalizeV v = mulSV (1 / magV v) v +{-# INLINE normalizeV #-} -- | Produce a unit vector at a given angle relative to the +ve x-axis. --- The provided angle is in radians. +-- The provided angle is in radians. unitVectorAtAngle :: Float -> Vector unitVectorAtAngle r - = (cos r, sin r) + = (cos r, sin r) {-# INLINE unitVectorAtAngle #-} diff --git a/Graphics/Gloss/Data/ViewPort.hs b/Graphics/Gloss/Data/ViewPort.hs --- a/Graphics/Gloss/Data/ViewPort.hs +++ b/Graphics/Gloss/Data/ViewPort.hs @@ -1,57 +1,76 @@ + module Graphics.Gloss.Data.ViewPort - ( ViewPort(..) - , viewPortInit - , applyViewPortToPicture - , invertViewPort ) + ( ViewPort(..) + , viewPortInit + , applyViewPortToPicture + , invertViewPort ) where -import Graphics.Gloss.Data.Vector -import Graphics.Gloss.Geometry.Angle -import Graphics.Gloss.Data.Picture (Picture(..)) -import Graphics.Gloss.Data.Point +import Graphics.Gloss.Data.Picture +import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt -- | The 'ViewPort' represents the global transformation applied to the displayed picture. -- When the user pans, zooms, or rotates the display then this changes the 'ViewPort'. data ViewPort - = ViewPort { - -- | Global translation. - viewPortTranslate :: !(Float, Float) + = ViewPort { + -- | Global translation. + viewPortTranslate :: !(Float, Float) - -- | Global rotation (in degrees). - , viewPortRotate :: !Float + -- | Global rotation (in degrees). + , viewPortRotate :: !Float - -- | Global scaling (of both x and y coordinates). - , viewPortScale :: !Float - } - - + -- | Global scaling (of both x and y coordinates). + , viewPortScale :: !Float + } + + -- | The initial state of the viewport. viewPortInit :: ViewPort viewPortInit - = ViewPort - { viewPortTranslate = (0, 0) - , viewPortRotate = 0 - , viewPortScale = 1 - } + = ViewPort + { viewPortTranslate = (0, 0) + , viewPortRotate = 0 + , viewPortScale = 1 + } -- | Translates, rotates, and scales an image according to the 'ViewPort'. applyViewPortToPicture :: ViewPort -> Picture -> Picture applyViewPortToPicture - ViewPort { viewPortScale = scale - , viewPortTranslate = (transX, transY) - , viewPortRotate = rotate } - = Scale scale scale . Rotate rotate . Translate transX transY + ViewPort { viewPortScale = vscale + , viewPortTranslate = (transX, transY) + , viewPortRotate = vrotate } + = Scale vscale vscale . Rotate vrotate . Translate transX transY -- | Takes a point using screen coordinates, and uses the `ViewPort` to convert --- it to Picture coordinates. This is the inverse of `applyViewPortToPicture` +-- it to Picture coordinates. This is the inverse of `applyViewPortToPicture` -- for points. invertViewPort :: ViewPort -> Point -> Point invertViewPort - ViewPort { viewPortScale = scale - , viewPortTranslate = trans - , viewPortRotate = rotate } + ViewPort { viewPortScale = vscale + , viewPortTranslate = vtrans + , viewPortRotate = vrotate } pos - = rotateV (degToRad rotate) (mulSV (1 / scale) pos) - trans + = rotateV (degToRad vrotate) (mulSV (1 / vscale) pos) Pt.- vtrans + +-- | Convert degrees to radians +degToRad :: Float -> Float +degToRad d = d * pi / 180 +{-# INLINE degToRad #-} + + +-- | Multiply a vector by a scalar. +mulSV :: Float -> Vector -> Vector +mulSV s (x, y) + = (s * x, s * y) +{-# INLINE mulSV #-} + + +-- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise. +rotateV :: Float -> Vector -> Vector +rotateV r (x, y) + = ( x * cos r - y * sin r + , x * sin r + y * cos r) +{-# INLINE rotateV #-} diff --git a/Graphics/Gloss/Data/ViewState.hs b/Graphics/Gloss/Data/ViewState.hs --- a/Graphics/Gloss/Data/ViewState.hs +++ b/Graphics/Gloss/Data/ViewState.hs @@ -1,15 +1,14 @@ +{-# LANGUAGE PatternGuards #-} + module Graphics.Gloss.Data.ViewState ( Command (..) , CommandConfig , defaultCommandConfig , ViewState (..) - , ViewPort (..) , viewStateInit , viewStateInitWithConfig , updateViewStateWithEvent - , updateViewStateWithEventMaybe - , applyViewPortToPicture - , invertViewPort ) + , updateViewStateWithEventMaybe) where import Graphics.Gloss.Data.Vector import Graphics.Gloss.Data.ViewPort @@ -20,6 +19,7 @@ import Data.Map (Map) import Data.Maybe import Control.Monad (mplus) +import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt -- | The commands suported by the view controller. @@ -28,6 +28,7 @@ | CTranslate | CRotate + | CScale -- bump zoom | CBumpZoomOut @@ -57,13 +58,22 @@ , (CTranslate, [ ( MouseButton LeftButton - , Just (Modifiers { shift = Up, ctrl = Up, alt = Up })) + , Just (Modifiers { shift = Up, ctrl = Up, alt = Up })) ]) + , (CScale, + [ ( MouseButton LeftButton + , Just (Modifiers { shift = Up, ctrl = Down, alt = Up })) + + , ( MouseButton RightButton + , Just (Modifiers { shift = Up, ctrl = Up, alt = Up })) + ]) + , (CRotate, - [ ( MouseButton RightButton - , Nothing) - , ( MouseButton LeftButton + [ ( MouseButton LeftButton + , Just (Modifiers { shift = Up, ctrl = Up, alt = Down })) + + , ( MouseButton RightButton , Just (Modifiers { shift = Up, ctrl = Down, alt = Up })) ]) @@ -100,8 +110,8 @@ -- | Check if the provided key combination is some gloss viewport command. -isCommand - :: Map Command [(Key, Maybe Modifiers)] +isCommand + :: Map Command [(Key, Maybe Modifiers)] -> Command -> Key -> Modifiers -> Bool isCommand commands c key keyMods @@ -143,14 +153,22 @@ -- | How many degrees to rotate the world by for each pixel of x motion. , viewStateRotateFactor :: !Float + -- | Ratio to scale the world by for each pixel of y motion. + , viewStateScaleFactor :: !Float + -- | During viewport translation, - -- where the mouse was clicked on the window. + -- where the mouse was clicked on the window to start the translate. , viewStateTranslateMark :: !(Maybe (Float, Float)) - -- | During viewport rotation, - -- where the mouse was clicked on the window + -- | During viewport rotation, + -- where the mouse was clicked on the window to starte the rotate. , viewStateRotateMark :: !(Maybe (Float, Float)) + -- | During viewport scale, + -- where the mouse was clicked on the window to start the scale. + , viewStateScaleMark :: !(Maybe (Float, Float)) + + -- | The current viewport. , viewStateViewPort :: ViewPort } @@ -167,8 +185,10 @@ { viewStateCommands = Map.fromList commandConfig , viewStateScaleStep = 0.85 , viewStateRotateFactor = 0.6 + , viewStateScaleFactor = 0.01 , viewStateTranslateMark = Nothing , viewStateRotateMark = Nothing + , viewStateScaleMark = Nothing , viewStateViewPort = viewPortInit } @@ -212,100 +232,110 @@ | isCommand commands CBumpClockwise key keyMods , keyState == Down - = Just $ viewState { viewStateViewPort + = Just $ viewState { viewStateViewPort = port { viewPortRotate = viewPortRotate port + 5 } } | isCommand commands CBumpCClockwise key keyMods , keyState == Down - = Just $ viewState { viewStateViewPort + = Just $ viewState { viewStateViewPort = port { viewPortRotate = viewPortRotate port - 5 } } + + -- Start Translation. | isCommand commands CTranslate key keyMods , keyState == Down - , not currentlyRotating + , not $ currentlyRotating || currentlyScaling = Just $ viewState { viewStateTranslateMark = Just pos } - -- We don't want to use 'isCommand' here because the user may have - -- released the translation modifier key before the mouse button. - -- and we still want to cancel the translation. - | currentlyTranslating - , keyState == Up - = Just $ viewState { viewStateTranslateMark = Nothing } - + -- Start Rotation. | isCommand commands CRotate key keyMods , keyState == Down - , not currentlyTranslating + , not $ currentlyTranslating || currentlyScaling = Just $ viewState { viewStateRotateMark = Just pos } - -- We don't want to use 'isCommand' here because the user may have - -- released the rotation modifier key before the mouse button, - -- and we still want to cancel the rotation. - | currentlyRotating - , keyState == Up - = Just $ viewState { viewStateRotateMark = Nothing } + -- Start Scale. + | isCommand commands CScale key keyMods + , keyState == Down + , not $ currentlyTranslating || currentlyRotating + = Just $ viewState { viewStateScaleMark = Just pos } + + -- Kill current translate/rotate/scale command when the mouse button + -- is released. + | keyState == Up + = let killTranslate vs = vs { viewStateTranslateMark = Nothing } + killRotate vs = vs { viewStateRotateMark = Nothing } + killScale vs = vs { viewStateScaleMark = Nothing } + in Just + $ (if currentlyTranslating then killTranslate else id) + $ (if currentlyRotating then killRotate else id) + $ (if currentlyScaling then killScale else id) + $ viewState + | otherwise = Nothing where commands = viewStateCommands viewState port = viewStateViewPort viewState currentlyTranslating = isJust $ viewStateTranslateMark viewState - currentlyRotating = isJust $ viewStateRotateMark viewState + currentlyRotating = isJust $ viewStateRotateMark viewState + currentlyScaling = isJust $ viewStateScaleMark viewState -- Note that only a translation or rotation applies, not both at the same time. updateViewStateWithEventMaybe (EventMotion pos) viewState - = motionTranslate (viewStateTranslateMark viewState) pos viewState `mplus` + = motionScale (viewStateScaleMark viewState) pos viewState `mplus` + motionTranslate (viewStateTranslateMark viewState) pos viewState `mplus` motionRotate (viewStateRotateMark viewState) pos viewState -updateViewStateWithEventMaybe (EventResize _) _ +updateViewStateWithEventMaybe (EventResize _) _ = Nothing -- | Zoom in a `ViewState` by the scale step. controlZoomIn :: ViewState -> ViewState -controlZoomIn - viewState@ViewState +controlZoomIn + viewState@ViewState { viewStateViewPort = port , viewStateScaleStep = scaleStep } - = viewState - { viewStateViewPort - = port { viewPortScale = viewPortScale port * scaleStep } } + = viewState + { viewStateViewPort + = port { viewPortScale = viewPortScale port / scaleStep } } -- | Zoom out a `ViewState` by the scale step. controlZoomOut :: ViewState -> ViewState -controlZoomOut - viewState@ViewState +controlZoomOut + viewState@ViewState { viewStateViewPort = port , viewStateScaleStep = scaleStep } = viewState - { viewStateViewPort - = port { viewPortScale = viewPortScale port / scaleStep } } + { viewStateViewPort + = port { viewPortScale = viewPortScale port * scaleStep } } -- | Offset a viewport. motionBump :: ViewPort -> (Float, Float) -> ViewPort motionBump - port@ViewPort + port@ViewPort { viewPortTranslate = trans , viewPortScale = scale , viewPortRotate = r } (bumpX, bumpY) - = port { viewPortTranslate = trans - o } + = port { viewPortTranslate = trans Pt.- o } where offset = (bumpX / scale, bumpY / scale) o = rotateV (degToRad r) offset -- | Apply a translation to the `ViewState`. -motionTranslate - :: Maybe (Float, Float) - -> (Float, Float) +motionTranslate + :: Maybe (Float, Float) -- Location of first mark. + -> (Float, Float) -- Current position. -> ViewState -> Maybe ViewState motionTranslate Nothing _ _ = Nothing motionTranslate (Just (markX, markY)) (posX, posY) viewState = Just $ viewState - { viewStateViewPort = port { viewPortTranslate = trans - o } + { viewStateViewPort = port { viewPortTranslate = trans Pt.- o } , viewStateTranslateMark = Just (posX, posY) } where port = viewStateViewPort viewState @@ -319,19 +349,47 @@ -- | Apply a rotation to the `ViewState`. -motionRotate - :: Maybe (Float, Float) - -> (Float, Float) +motionRotate + :: Maybe (Float, Float) -- Location of first mark. + -> (Float, Float) -- Current position. -> ViewState -> Maybe ViewState motionRotate Nothing _ _ = Nothing motionRotate (Just (markX, _markY)) (posX, posY) viewState = Just $ viewState - { viewStateViewPort + { viewStateViewPort = port { viewPortRotate = rotate - rotateFactor * (posX - markX) } , viewStateRotateMark = Just (posX, posY) } where port = viewStateViewPort viewState rotate = viewPortRotate port rotateFactor = viewStateRotateFactor viewState + + +-- | Apply a scale to the `ViewState`. +motionScale + :: Maybe (Float, Float) -- Location of first mark. + -> (Float, Float) -- Current position. + -> ViewState -> Maybe ViewState + +motionScale Nothing _ _ = Nothing +motionScale (Just (_markX, markY)) (posX, posY) viewState + = Just $ viewState + { viewStateViewPort + = let -- Limit the amount of downward scaling so it maxes + -- out at 1 percent of the original. There's not much + -- point scaling down to no pixels, or going negative + -- so that the image is inverted. + ss = if posY > markY + then scale - scale * (scaleFactor * (posY - markY)) + else scale + scale * (scaleFactor * (markY - posY)) + + ss' = max 0.01 ss + in port { viewPortScale = ss' } + + , viewStateScaleMark = Just (posX, posY) } + where port = viewStateViewPort viewState + scale = viewPortScale port + scaleFactor = viewStateScaleFactor viewState + diff --git a/Graphics/Gloss/Geometry.hs b/Graphics/Gloss/Geometry.hs deleted file mode 100644 --- a/Graphics/Gloss/Geometry.hs +++ /dev/null @@ -1,8 +0,0 @@ - -module Graphics.Gloss.Geometry - ( module Graphics.Gloss.Geometry.Angle - , module Graphics.Gloss.Geometry.Line ) -where -import Graphics.Gloss.Geometry.Angle -import Graphics.Gloss.Geometry.Line - diff --git a/Graphics/Gloss/Geometry/Angle.hs b/Graphics/Gloss/Geometry/Angle.hs --- a/Graphics/Gloss/Geometry/Angle.hs +++ b/Graphics/Gloss/Geometry/Angle.hs @@ -1,25 +1,25 @@ -- | Geometric functions concerning angles. If not otherwise specified, all angles are in radians. module Graphics.Gloss.Geometry.Angle - ( degToRad - , radToDeg - , normaliseAngle ) + ( degToRad + , radToDeg + , normalizeAngle ) where -- | Convert degrees to radians -{-# INLINE degToRad #-} degToRad :: Float -> Float -degToRad d = d * pi / 180 +degToRad d = d * pi / 180 +{-# INLINE degToRad #-} -- | Convert radians to degrees -{-# INLINE radToDeg #-} radToDeg :: Float -> Float -radToDeg r = r * 180 / pi +radToDeg r = r * 180 / pi +{-# INLINE radToDeg #-} --- | Normalise an angle to be between 0 and 2*pi radians -{-# INLINE normaliseAngle #-} -normaliseAngle :: Float -> Float -normaliseAngle f = f - 2 * pi * floor' (f / (2 * pi)) +-- | Normalize an angle to be between 0 and 2*pi radians +normalizeAngle :: Float -> Float +normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi)) where floor' :: Float -> Float floor' x = fromIntegral (floor x :: Int) +{-# INLINE normalizeAngle #-} diff --git a/Graphics/Gloss/Geometry/Line.hs b/Graphics/Gloss/Geometry/Line.hs --- a/Graphics/Gloss/Geometry/Line.hs +++ b/Graphics/Gloss/Geometry/Line.hs @@ -3,68 +3,67 @@ -- | Geometric functions concerning lines and segments. -- -- A @Line@ is taken to be infinite in length, while a @Seg@ is finite length --- line segment represented by its two endpoints. +-- line segment represented by its two endpoints. module Graphics.Gloss.Geometry.Line - ( segClearsBox + ( segClearsBox - - -- * Closest points - , closestPointOnLine - , closestPointOnLineParam + -- * Closest points + , closestPointOnLine + , closestPointOnLineParam - -- * Line-Line intersection - , intersectLineLine + -- * Line-Line intersection + , intersectLineLine - -- * Seg-Line intersection - , intersectSegLine - , intersectSegHorzLine - , intersectSegVertLine + -- * Seg-Line intersection + , intersectSegLine + , intersectSegHorzLine + , intersectSegVertLine - -- * Seg-Seg intersection - , intersectSegSeg - , intersectSegHorzSeg - , intersectSegVertSeg) - + -- * Seg-Seg intersection + , intersectSegSeg + , intersectSegHorzSeg + , intersectSegVertSeg) + where import Graphics.Gloss.Data.Point import Graphics.Gloss.Data.Vector - +import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt -- | Check if line segment (P1-P2) clears a box (P3-P4) by being well outside it. -segClearsBox - :: Point -- ^ P1 First point of segment. - -> Point -- ^ P2 Second point of segment. - -> Point -- ^ P3 Lower left point of box. - -> Point -- ^ P4 Upper right point of box. - -> Bool +segClearsBox + :: Point -- ^ P1 First point of segment. + -> Point -- ^ P2 Second point of segment. + -> Point -- ^ P3 Lower left point of box. + -> Point -- ^ P4 Upper right point of box. + -> Bool segClearsBox (x1, y1) (x2, y2) (xa, ya) (xb, yb) - | x1 < xa, x2 < xa = True - | x1 > xb, x2 > xb = True - | y1 < ya, y2 < ya = True - | y1 > yb, y2 > yb = True - | otherwise = False + | x1 < xa, x2 < xa = True + | x1 > xb, x2 > xb = True + | y1 < ya, y2 < ya = True + | y1 > yb, y2 > yb = True + | otherwise = False -- | Given an infinite line which intersects `P1` and `P1`, --- return the point on that line that is closest to `P3` +-- return the point on that line that is closest to `P3` closestPointOnLine - :: Point -- ^ `P1` - -> Point -- ^ `P2` - -> Point -- ^ `P3` - -> Point -- ^ the point on the line P1-P2 that is closest to `P3` + :: Point -- ^ `P1` + -> Point -- ^ `P2` + -> Point -- ^ `P3` + -> Point -- ^ the point on the line P1-P2 that is closest to `P3` {-# INLINE closestPointOnLine #-} closestPointOnLine p1 p2 p3 - = p1 + (u `mulSV` (p2 - p1)) - where u = closestPointOnLineParam p1 p2 p3 + = p1 Pt.+ (u `mulSV` (p2 Pt.- p1)) + where u = closestPointOnLineParam p1 p2 p3 -- | Given an infinite line which intersects P1 and P2, --- let P4 be the point on the line that is closest to P3. +-- let P4 be the point on the line that is closest to P3. -- --- Return an indication of where on the line P4 is relative to P1 and P2. +-- Return an indication of where on the line P4 is relative to P1 and P2. -- -- @ -- if P4 == P1 then 0 @@ -75,23 +74,23 @@ -- @ -- | -- P1 --- | --- P4 +---- P3 -- | +-- P4 +---- P3 +-- | -- P2 -- | -- @ -- {-# INLINE closestPointOnLineParam #-} closestPointOnLineParam - :: Point -- ^ `P1` - -> Point -- ^ `P2` - -> Point -- ^ `P3` - -> Float + :: Point -- ^ `P1` + -> Point -- ^ `P2` + -> Point -- ^ `P3` + -> Float closestPointOnLineParam p1 p2 p3 - = (p3 - p1) `dotV` (p2 - p1) - / (p2 - p1) `dotV` (p2 - p1) + = (p3 Pt.- p1) `dotV` (p2 Pt.- p1) + / (p2 Pt.- p1) `dotV` (p2 Pt.- p1) @@ -111,31 +110,31 @@ -- / \\ -- @ -- -intersectLineLine - :: Point -- ^ `P1` - -> Point -- ^ `P2` - -> Point -- ^ `P3` - -> Point -- ^ `P4` - -> Maybe Point +intersectLineLine + :: Point -- ^ `P1` + -> Point -- ^ `P2` + -> Point -- ^ `P3` + -> Point -- ^ `P4` + -> Maybe Point intersectLineLine (x1, y1) (x2, y2) (x3, y3) (x4, y4) - = let dx12 = x1 - x2 - dx34 = x3 - x4 + = let dx12 = x1 - x2 + dx34 = x3 - x4 - dy12 = y1 - y2 - dy34 = y3 - y4 - - den = dx12 * dy34 - dy12 * dx34 + dy12 = y1 - y2 + dy34 = y3 - y4 + den = dx12 * dy34 - dy12 * dx34 + in if den == 0 - then Nothing - else let - det12 = x1*y2 - y1*x2 - det34 = x3*y4 - y3*x4 + then Nothing + else let + det12 = x1*y2 - y1*x2 + det34 = x3*y4 - y3*x4 - numx = det12 * dx34 - dx12 * det34 - numy = det12 * dy34 - dy12 * det34 - in Just (numx / den, numy / den) + numx = det12 * dx34 - dx12 * det34 + numy = det12 * dy34 - dy12 * det34 + in Just (numx / den, numy / den) -- Segment-Line intersection -------------------------------------------------- @@ -143,26 +142,26 @@ -- if any. -- intersectSegLine - :: Point -- ^ `P1` - -> Point -- ^ `P2` - -> Point -- ^ `P3` - -> Point -- ^ `P4` - -> Maybe Point + :: Point -- ^ `P1` + -> Point -- ^ `P2` + -> Point -- ^ `P3` + -> Point -- ^ `P4` + -> Maybe Point intersectSegLine p1 p2 p3 p4 - -- TODO: merge closest point check with intersection, reuse subterms. - | Just p0 <- intersectLineLine p1 p2 p3 p4 - , t12 <- closestPointOnLineParam p1 p2 p0 - , t12 >= 0 && t12 <= 1 - = Just p0 - - | otherwise - = Nothing - + -- TODO: merge closest point check with intersection, reuse subterms. + | Just p0 <- intersectLineLine p1 p2 p3 p4 + , t12 <- closestPointOnLineParam p1 p2 p0 + , t12 >= 0 && t12 <= 1 + = Just p0 + | otherwise + = Nothing + + -- | Get the point where a segment crosses a horizontal line, if any. -- --- @ +-- @ -- + P1 -- / -- -------+--------- @@ -170,34 +169,34 @@ -- P2 + -- @ -- -intersectSegHorzLine - :: Point -- ^ P1 First point of segment. - -> Point -- ^ P2 Second point of segment. - -> Float -- ^ y value of line. - -> Maybe Point +intersectSegHorzLine + :: Point -- ^ P1 First point of segment. + -> Point -- ^ P2 Second point of segment. + -> Float -- ^ y value of line. + -> Maybe Point intersectSegHorzLine (x1, y1) (x2, y2) y0 - - -- seg is on line - | y1 == y0, y2 == y0 = Nothing - - -- seg is above line - | y1 > y0, y2 > y0 = Nothing - - -- seg is below line - | y1 < y0, y2 < y0 = Nothing - - -- seg is a single point on the line. - -- this should be caught by the first case, - -- but we'll test for it anyway. - | y2 - y1 == 0 - = Just (x1, y1) - - | otherwise - = Just ( (y0 - y1) * (x2 - x1) / (y2 - y1) + x1 - , y0) + -- seg is on line + | y1 == y0, y2 == y0 = Nothing + -- seg is above line + | y1 > y0, y2 > y0 = Nothing + -- seg is below line + | y1 < y0, y2 < y0 = Nothing + + -- seg is a single point on the line. + -- this should be caught by the first case, + -- but we'll test for it anyway. + | y2 - y1 == 0 + = Just (x1, y1) + + | otherwise + = Just ( (y0 - y1) * (x2 - x1) / (y2 - y1) + x1 + , y0) + + + -- | Get the point where a segment crosses a vertical line, if any. -- -- @ @@ -210,58 +209,58 @@ -- | x0 -- @ -- -intersectSegVertLine - :: Point -- ^ P1 First point of segment. - -> Point -- ^ P2 Second point of segment. - -> Float -- ^ x value of line. - -> Maybe Point +intersectSegVertLine + :: Point -- ^ P1 First point of segment. + -> Point -- ^ P2 Second point of segment. + -> Float -- ^ x value of line. + -> Maybe Point intersectSegVertLine (x1, y1) (x2, y2) x0 - - -- seg is on line - | x1 == x0, x2 == x0 = Nothing - - -- seg is to right of line - | x1 > x0, x2 > x0 = Nothing - - -- seg is to left of line - | x1 < x0, x2 < x0 = Nothing - - -- seg is a single point on the line. - -- this should be caught by the first case, - -- but we'll test for it anyway. - | x2 - x1 == 0 - = Just (x1, y1) - - | otherwise - = Just ( x0 - , (x0 - x1) * (y2 - y1) / (x2 - x1) + y1) + -- seg is on line + | x1 == x0, x2 == x0 = Nothing + -- seg is to right of line + | x1 > x0, x2 > x0 = Nothing + + -- seg is to left of line + | x1 < x0, x2 < x0 = Nothing + + -- seg is a single point on the line. + -- this should be caught by the first case, + -- but we'll test for it anyway. + | x2 - x1 == 0 + = Just (x1, y1) + + | otherwise + = Just ( x0 + , (x0 - x1) * (y2 - y1) / (x2 - x1) + y1) + + -- Segment-Segment intersection ----------------------------------------------- -- | Get the point where a segment @P1-P2@ crosses another segement @P3-P4@, -- if any. intersectSegSeg - :: Point -- ^ `P1` - -> Point -- ^ `P2` - -> Point -- ^ `P3` - -> Point -- ^ `P4` - -> Maybe Point + :: Point -- ^ `P1` + -> Point -- ^ `P2` + -> Point -- ^ `P3` + -> Point -- ^ `P4` + -> Maybe Point intersectSegSeg p1 p2 p3 p4 - -- TODO: merge closest point checks with intersection, reuse subterms. - | Just p0 <- intersectLineLine p1 p2 p3 p4 - , t12 <- closestPointOnLineParam p1 p2 p0 - , t23 <- closestPointOnLineParam p3 p4 p0 - , t12 >= 0 && t12 <= 1 - , t23 >= 0 && t23 <= 1 - = Just p0 - - | otherwise - = Nothing + -- TODO: merge closest point checks with intersection, reuse subterms. + | Just p0 <- intersectLineLine p1 p2 p3 p4 + , t12 <- closestPointOnLineParam p1 p2 p0 + , t23 <- closestPointOnLineParam p3 p4 p0 + , t12 >= 0 && t12 <= 1 + , t23 >= 0 && t23 <= 1 + = Just p0 + | otherwise + = Nothing + -- | Check if an arbitrary segment intersects a horizontal segment. -- -- @ @@ -270,28 +269,28 @@ -- (xa, y3) +---+----+ (xb, y3) -- / -- P1 + --- @ +-- @ intersectSegHorzSeg - :: Point -- ^ P1 First point of segment. - -> Point -- ^ P2 Second point of segment. - -> Float -- ^ (y3) y value of horizontal segment. - -> Float -- ^ (xa) Leftmost x value of horizontal segment. - -> Float -- ^ (xb) Rightmost x value of horizontal segment. - -> Maybe Point -- ^ (x3, y3) Intersection point, if any. - + :: Point -- ^ P1 First point of segment. + -> Point -- ^ P2 Second point of segment. + -> Float -- ^ (y3) y value of horizontal segment. + -> Float -- ^ (xa) Leftmost x value of horizontal segment. + -> Float -- ^ (xb) Rightmost x value of horizontal segment. + -> Maybe Point -- ^ (x3, y3) Intersection point, if any. + intersectSegHorzSeg p1@(x1, y1) p2@(x2, y2) y0 xa xb - | segClearsBox p1 p2 (xa, y0) (xb, y0) - = Nothing + | segClearsBox p1 p2 (xa, y0) (xb, y0) + = Nothing - | x0 < xa = Nothing - | x0 > xb = Nothing - | otherwise = Just (x0, y0) - - where x0 | (y2 - y1) == 0 = x1 - | otherwise = (y0 - y1) * (x2 - x1) / (y2 - y1) + x1 + | x0 < xa = Nothing + | x0 > xb = Nothing + | otherwise = Just (x0, y0) + where x0 | (y2 - y1) == 0 = x1 + | otherwise = (y0 - y1) * (x2 - x1) / (y2 - y1) + x1 + -- | Check if an arbitrary segment intersects a vertical segment. -- -- @ @@ -302,25 +301,25 @@ -- / | -- P2 + | -- + (x3, ya) --- @ +-- @ intersectSegVertSeg - :: Point -- ^ P1 First point of segment. - -> Point -- ^ P2 Second point of segment. - -> Float -- ^ (x3) x value of vertical segment - -> Float -- ^ (ya) Lowest y value of vertical segment. - -> Float -- ^ (yb) Highest y value of vertical segment. - -> Maybe Point -- ^ (x3, y3) Intersection point, if any. + :: Point -- ^ P1 First point of segment. + -> Point -- ^ P2 Second point of segment. + -> Float -- ^ (x3) x value of vertical segment + -> Float -- ^ (ya) Lowest y value of vertical segment. + -> Float -- ^ (yb) Highest y value of vertical segment. + -> Maybe Point -- ^ (x3, y3) Intersection point, if any. intersectSegVertSeg p1@(x1, y1) p2@(x2, y2) x0 ya yb - | segClearsBox p1 p2 (x0, ya) (x0, yb) - = Nothing - - | y0 < ya = Nothing - | y0 > yb = Nothing - | otherwise = Just (x0, y0) - - where y0 | (x2 - x1) == 0 = y1 - | otherwise = (x0 - x1) * (y2 - y1) / (x2 - x1) + y1 + | segClearsBox p1 p2 (x0, ya) (x0, yb) + = Nothing + + | y0 < ya = Nothing + | y0 > yb = Nothing + | otherwise = Just (x0, y0) + + where y0 | (x2 - x1) == 0 = y1 + | otherwise = (x0 - x1) * (y2 - y1) / (x2 - x1) + y1 diff --git a/Graphics/Gloss/Interface/Environment.hs b/Graphics/Gloss/Interface/Environment.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/Environment.hs @@ -0,0 +1,18 @@ +module Graphics.Gloss.Interface.Environment where + +import Data.IORef (newIORef) + +import qualified Graphics.Gloss.Internals.Interface.Backend.Types as Backend.Types +import Graphics.Gloss.Internals.Interface.Backend (defaultBackendState) + +-- | Get the size of the screen, in pixels. +-- +-- This will be the size of the rendered gloss image when +-- fullscreen mode is enabled. +-- +getScreenSize :: IO (Int, Int) +getScreenSize = do + backendStateRef <- newIORef defaultBackendState + Backend.Types.initializeBackend backendStateRef False + Backend.Types.getScreenSize backendStateRef + diff --git a/Graphics/Gloss/Interface/IO/Animate.hs b/Graphics/Gloss/Interface/IO/Animate.hs --- a/Graphics/Gloss/Interface/IO/Animate.hs +++ b/Graphics/Gloss/Interface/IO/Animate.hs @@ -1,13 +1,15 @@ --- | Display mode is for drawing a static picture. +-- | Animate a picture in a window. module Graphics.Gloss.Interface.IO.Animate ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture , module Graphics.Gloss.Data.Color , animateIO - , animateFixedIO) + , animateFixedIO + , Controller (..)) where import Graphics.Gloss.Data.Display +import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Interface.Animate @@ -18,19 +20,22 @@ -- -- Once the window is open you can use the same commands as with @display@. -- -animateIO +animateIO :: Display -- ^ Display mode. -> Color -- ^ Background color. - -> (Float -> IO Picture) -- ^ Function to produce the next frame of animation. + -> (Float -> IO Picture) -- ^ Function to produce the next frame of animation. -- It is passed the time in seconds since the program started. + -> (Controller -> IO ()) -- ^ Callback to take the display controller. -> IO () -animateIO display backColor frameFunIO - = animateWithBackendIO - defaultBackendState +animateIO display backColor + frameFunIO eatControllerIO + = animateWithBackendIO + defaultBackendState True -- pannable display backColor frameFunIO + eatControllerIO -- | Like `animateIO` but don't allow the display to be panned around. @@ -38,12 +43,17 @@ animateFixedIO :: Display -- ^ Display mode. -> Color -- ^ Background color. - -> (Float -> IO Picture) -- ^ Function to produce the next frame of animation. + -> (Float -> IO Picture) -- ^ Function to produce the next frame of animation. -- It is passed the time in seconds since the program started. + -> (Controller -> IO ()) -- ^ Callback to take the display controller. -> IO () -animateFixedIO display backColor frameFunIO - = animateWithBackendIO - defaultBackendState + +animateFixedIO display backColor + frameFunIO eatControllerIO + = animateWithBackendIO + defaultBackendState False display backColor frameFunIO + eatControllerIO + diff --git a/Graphics/Gloss/Interface/IO/Display.hs b/Graphics/Gloss/Interface/IO/Display.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/IO/Display.hs @@ -0,0 +1,67 @@ + +-- | Display mode is for drawing a static picture. +module Graphics.Gloss.Interface.IO.Display + ( module Graphics.Gloss.Data.Display + , module Graphics.Gloss.Data.Picture + , module Graphics.Gloss.Data.Color + , displayIO + , Controller (..)) +where +import Graphics.Gloss.Data.Display +import Graphics.Gloss.Data.Controller +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.Display +import Graphics.Gloss.Internals.Interface.Backend + + +-- | Open a new window and display an infrequently updated picture. +-- +-- Once the window is open you can use the same commands as with @display@. +-- +-- * This wrapper is intended for mostly static pictures that do not +-- need to be updated more than once per second. For example, the picture +-- could show network activity over the last minute, a daily stock price, +-- or a weather forecast. If you want to show a real-time animation where +-- the frames are redrawn more frequently then use the `animate` wrapper +-- instead. +-- +-- * The provided picture generating action will be invoked, and the +-- display redrawn in two situation: +-- 1) We receive a display event, like someone clicks on the window. +-- 2) When `controllerSetRedraw` has been set, some indeterminate time +-- between the last redraw, and one second from that. +-- +-- * Note that calling `controllerSetRedraw` indicates that the picture should +-- be redrawn, but does not cause this to happen immediately, due to +-- limitations in the GLUT and GLFW window managers. The display runs on +-- a one second timer interrupt, and if there have been no display events +-- we need to wait for the next timer interrupt before redrawing. +-- Having the timer interrupt period at 1 second keeps the CPU usage +-- due to the context switches at under 1%. +-- +-- * Also note that the picture generating action is called for every display +-- event, so if the user pans the display then it will be invoked at 10hz +-- or more during the pan. If you are generating the picture by reading some +-- on-disk files then you should track when the files were last updated +-- and cache the picture between updates. Caching the picture avoids +-- repeatedly reading and re-parsing your files during a pan. Consider +-- storing your current picture in an IORef, passing an action that just +-- reads this IORef, and forking a new thread that watches your files for updates. +-- +displayIO + :: Display -- ^ Display mode. + -> Color -- ^ Background color. + -> IO Picture -- ^ Action to produce the current picture. + -> (Controller -> IO ()) -- ^ Callback to take the display controller. + -> IO () + +displayIO dis backColor makePicture eatController + = displayWithBackend + defaultBackendState + dis + backColor + makePicture + eatController + + diff --git a/Graphics/Gloss/Interface/IO/Game.hs b/Graphics/Gloss/Interface/IO/Game.hs --- a/Graphics/Gloss/Interface/IO/Game.hs +++ b/Graphics/Gloss/Interface/IO/Game.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ExplicitForAll #-} -- | This game mode lets you manage your own input. Pressing ESC will not abort the program. --- You also don't get automatic pan and zoom controls like with `displayInWindow`. +-- You also don't get automatic pan and zoom controls like with `display`. module Graphics.Gloss.Interface.IO.Game ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture @@ -16,7 +16,7 @@ import Graphics.Gloss.Internals.Interface.Backend --- | Play a game in a window, using IO actions to build the pictures. +-- | Play a game in a window, using IO actions to build the pictures. playIO :: forall world . Display -- ^ Display mode. -> Color -- ^ Background color. @@ -30,6 +30,7 @@ playIO display backColor simResolution worldStart worldToPicture worldHandleEvent worldAdvance + = playWithBackendIO defaultBackendState display backColor simResolution worldStart worldToPicture worldHandleEvent worldAdvance diff --git a/Graphics/Gloss/Interface/IO/Interact.hs b/Graphics/Gloss/Interface/IO/Interact.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/IO/Interact.hs @@ -0,0 +1,41 @@ + +-- | Display mode is for drawing a static picture. +module Graphics.Gloss.Interface.IO.Interact + ( module Graphics.Gloss.Data.Display + , module Graphics.Gloss.Data.Picture + , module Graphics.Gloss.Data.Color + , interactIO + , Controller (..) + , Event(..), Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..)) +where +import Graphics.Gloss.Data.Display +import Graphics.Gloss.Data.Controller +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.Event +import Graphics.Gloss.Internals.Interface.Interact +import Graphics.Gloss.Internals.Interface.Backend + + +-- | Open a new window and interact with an infrequently updated picture. +-- +-- Similar to `displayIO`, except that you manage your own events. +-- +interactIO + :: Display -- ^ Display mode. + -> Color -- ^ Background color. + -> world -- ^ Initial world state. + -> (world -> IO Picture) -- ^ A function to produce the current picture. + -> (Event -> world -> IO world) -- ^ A function to handle input events. + -> (Controller -> IO ()) -- ^ Callback to take the display controller. + -> IO () + +interactIO dis backColor worldInit makePicture handleEvent eatController + = interactWithBackend + defaultBackendState + dis + backColor + worldInit + makePicture + handleEvent + eatController diff --git a/Graphics/Gloss/Interface/IO/Simulate.hs b/Graphics/Gloss/Interface/IO/Simulate.hs --- a/Graphics/Gloss/Interface/IO/Simulate.hs +++ b/Graphics/Gloss/Interface/IO/Simulate.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes #-} --- We export this stuff separately so we don't clutter up the +-- We export this stuff separately so we don't clutter up the -- API of the Graphics.Gloss module. -- | Simulate mode is for producing an animation of some model who's picture @@ -16,7 +16,7 @@ import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color -import Graphics.Gloss.Data.ViewState +import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Internals.Interface.Simulate import Graphics.Gloss.Internals.Interface.Backend @@ -27,8 +27,8 @@ -> Int -- ^ Number of simulation steps to take for each second of real time. -> model -- ^ The initial model. -> (model -> IO Picture) -- ^ A function to convert the model to a picture. - -> (ViewPort -> Float -> model -> IO model) - -- ^ A function to step the model one iteration. It is passed the + -> (ViewPort -> Float -> model -> IO model) + -- ^ A function to step the model one iteration. It is passed the -- current viewport and the amount of time for this simulation -- step (in seconds). -> IO () diff --git a/Graphics/Gloss/Interface/Pure/Animate.hs b/Graphics/Gloss/Interface/Pure/Animate.hs --- a/Graphics/Gloss/Interface/Pure/Animate.hs +++ b/Graphics/Gloss/Interface/Pure/Animate.hs @@ -1,10 +1,10 @@ -- | Display mode is for drawing a static picture. module Graphics.Gloss.Interface.Pure.Animate - ( module Graphics.Gloss.Data.Display + ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color - , animate) + , module Graphics.Gloss.Data.Color + , animate) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture @@ -15,17 +15,18 @@ -- | Open a new window and display the given animation. -- --- Once the window is open you can use the same commands as with @display@. +-- Once the window is open you can use the same commands as with `display`. -- animate :: Display -- ^ Display mode. -> Color -- ^ Background color. - -> (Float -> Picture) -- ^ Function to produce the next frame of animation. + -> (Float -> Picture) -- ^ Function to produce the next frame of animation. -- It is passed the time in seconds since the program started. -> IO () animate display backColor frameFun - = animateWithBackendIO + = animateWithBackendIO defaultBackendState True -- pannable display backColor - (return . frameFun) + (return . frameFun) + (const (return ())) diff --git a/Graphics/Gloss/Interface/Pure/Display.hs b/Graphics/Gloss/Interface/Pure/Display.hs --- a/Graphics/Gloss/Interface/Pure/Display.hs +++ b/Graphics/Gloss/Interface/Pure/Display.hs @@ -1,10 +1,10 @@ -- | Display mode is for drawing a static picture. module Graphics.Gloss.Interface.Pure.Display - ( module Graphics.Gloss.Data.Display + ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color - , display) + , module Graphics.Gloss.Data.Color + , display) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture @@ -14,20 +14,15 @@ -- | Open a new window and display the given picture. --- --- Use the following commands once the window is open: --- --- * Quit - esc-key. --- --- * Move Viewport - left-click drag, arrow keys. --- --- * Rotate Viewport - right-click drag, control-left-click drag, or home\/end-keys. --- --- * Zoom Viewport - mouse wheel, or page up\/down-keys. --- display :: Display -- ^ Display mode. -> Color -- ^ Background color. -> Picture -- ^ The picture to draw. -> IO () -display = displayWithBackend defaultBackendState +display dis backColor picture + = displayWithBackend + defaultBackendState + dis + backColor + (return picture) + (const (return ())) diff --git a/Graphics/Gloss/Interface/Pure/Game.hs b/Graphics/Gloss/Interface/Pure/Game.hs --- a/Graphics/Gloss/Interface/Pure/Game.hs +++ b/Graphics/Gloss/Interface/Pure/Game.hs @@ -1,16 +1,16 @@ {-# LANGUAGE ExplicitForAll #-} --- We export this stuff separately so we don't clutter up the +-- We export this stuff separately so we don't clutter up the -- API of the Graphics.Gloss module. -- | This game mode lets you manage your own input. Pressing ESC will still abort the program, -- but you don't get automatic pan and zoom controls like with `displayInWindow`. module Graphics.Gloss.Interface.Pure.Game - ( module Graphics.Gloss.Data.Display + ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color - , play - , Event(..), Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..)) + , module Graphics.Gloss.Data.Color + , play + , Event(..), Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..)) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture @@ -19,25 +19,27 @@ import Graphics.Gloss.Internals.Interface.Backend --- | Play a game in a window. -play :: forall world - . Display -- ^ Display mode. - -> Color -- ^ Background color. - -> Int -- ^ Number of simulation steps to take for each second of real time. - -> world -- ^ The initial world. - -> (world -> Picture) -- ^ 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. +-- | Play a game in a window. Like `simulate`, but you manage your own input events. +play :: Display -- ^ Display mode. + -> Color -- ^ Background color. + -> Int -- ^ Number of simulation steps to take for each second of real time. + -> world -- ^ The initial world. + -> (world -> Picture) -- ^ 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 () play display backColor simResolution worldStart worldToPicture worldHandleEvent worldAdvance - = playWithBackendIO defaultBackendState - display backColor simResolution - worldStart - (return . worldToPicture) - (\event world -> return $ worldHandleEvent event world) - (\time world -> return $ worldAdvance time world) - True + = do _ <- playWithBackendIO defaultBackendState + display backColor simResolution + worldStart + (return . worldToPicture) + (\event world -> return $ worldHandleEvent event world) + (\time world -> return $ worldAdvance time world) + True + return () diff --git a/Graphics/Gloss/Interface/Pure/Simulate.hs b/Graphics/Gloss/Interface/Pure/Simulate.hs --- a/Graphics/Gloss/Interface/Pure/Simulate.hs +++ b/Graphics/Gloss/Interface/Pure/Simulate.hs @@ -1,16 +1,16 @@ {-# LANGUAGE RankNTypes #-} --- We export this stuff separately so we don't clutter up the +-- We export this stuff separately so we don't clutter up the -- API of the Graphics.Gloss module. -- | Simulate mode is for producing an animation of some model who's picture -- changes over finite time steps. The behavior of the model can also depent -- on the current `ViewPort`. module Graphics.Gloss.Interface.Pure.Simulate - ( module Graphics.Gloss.Data.Display + ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color - , simulate + , module Graphics.Gloss.Data.Color + , simulate , ViewPort(..)) where import Graphics.Gloss.Data.Display @@ -22,29 +22,32 @@ -- | Run a finite-time-step simulation in a window. You decide how the model is represented, --- how to convert the model to a picture, and how to advance the model for each unit of time. +-- how to convert the model to a picture, and how to advance the model for each unit of time. -- This function does the rest. -- --- Once the window is open you can use the same commands as with @display@. +-- Once the window is open you can use the same commands as with `display`. -- -simulate :: forall model - . Display -- ^ Display mode. - -> Color -- ^ Background color. - -> Int -- ^ Number of simulation steps to take for each second of real time. - -> model -- ^ The initial model. - -> (model -> Picture) -- ^ A function to convert the model to a picture. - -> (ViewPort -> Float -> model -> model) -- ^ A function to step the model one iteration. It is passed the - -- current viewport and the amount of time for this simulation - -- step (in seconds). +simulate + :: Display -- ^ Display mode. + -> Color -- ^ Background color. + -> Int -- ^ Number of simulation steps to take for each second of real time. + -> model -- ^ The initial model. + -> (model -> Picture) + -- ^ A function to convert the model to a picture. + -> (ViewPort -> Float -> model -> model) + -- ^ A function to step the model one iteration. It is passed the + -- current viewport and the amount of time for this simulation + -- step (in seconds). -> IO () -simulate display backColor simResolution +simulate display backColor simResolution modelStart modelToPicture modelStep - = simulateWithBackendIO defaultBackendState - display backColor simResolution - modelStart - (return . modelToPicture) - (\view time model -> return $ modelStep view time model) + = do _ <- simulateWithBackendIO defaultBackendState + display backColor simResolution + modelStart + (return . modelToPicture) + (\view time model -> return $ modelStep view time model) + return () - + diff --git a/Graphics/Gloss/Internals/Color.hs b/Graphics/Gloss/Internals/Color.hs --- a/Graphics/Gloss/Internals/Color.hs +++ b/Graphics/Gloss/Internals/Color.hs @@ -3,17 +3,17 @@ module Graphics.Gloss.Internals.Color where import Graphics.Gloss.Data.Color -import qualified Graphics.Rendering.OpenGL.GL as GL +import qualified Graphics.Rendering.OpenGL.GL as GL import Unsafe.Coerce -- | Convert one of our Colors to OpenGL's representation. -glColor4OfColor :: Fractional a => Color -> GL.Color4 a +glColor4OfColor :: Color -> GL.Color4 a glColor4OfColor color = case rgbaOfColor color of - (r, g, b, a) - -> let rF = unsafeCoerce r - gF = unsafeCoerce g - bF = unsafeCoerce b - aF = unsafeCoerce a - in GL.Color4 rF gF bF aF + (r, g, b, a) + -> let rF = unsafeCoerce r + gF = unsafeCoerce g + bF = unsafeCoerce b + aF = unsafeCoerce a + in GL.Color4 rF gF bF aF diff --git a/Graphics/Gloss/Internals/Interface/Animate.hs b/Graphics/Gloss/Internals/Interface/Animate.hs --- a/Graphics/Gloss/Internals/Interface/Animate.hs +++ b/Graphics/Gloss/Internals/Interface/Animate.hs @@ -1,12 +1,13 @@ module Graphics.Gloss.Internals.Interface.Animate - (animateWithBackendIO) -where + (animateWithBackendIO) +where import Graphics.Gloss.Data.Color +import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Data.ViewState -import Graphics.Gloss.Internals.Render.Common -import Graphics.Gloss.Internals.Render.Picture +import Graphics.Gloss.Rendering import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit @@ -14,65 +15,90 @@ import Graphics.Gloss.Internals.Interface.ViewState.Motion import Graphics.Gloss.Internals.Interface.ViewState.Reshape import Graphics.Gloss.Internals.Interface.Animate.Timing -import qualified Graphics.Gloss.Internals.Render.State as RS -import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN -import qualified Graphics.Gloss.Internals.Interface.Callback as Callback +import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN +import qualified Graphics.Gloss.Internals.Interface.Callback as Callback import Data.IORef -import Data.Functor ((<$>)) import Control.Monad import System.Mem import GHC.Float (double2Float) + animateWithBackendIO - :: Backend a - => a -- ^ Initial State of the backend + :: Backend a + => a -- ^ Initial State of the backend -> Bool -- ^ Whether to allow the image to be panned around. -> Display -- ^ Display mode. - -> Color -- ^ Background color. - -> (Float -> IO Picture) -- ^ Function to produce the next frame of animation. + -> Color -- ^ Background color. + -> (Float -> IO Picture) -- ^ Function to produce the next frame of animation. -- It is passed the time in seconds since the program started. - -> IO () + -> (Controller -> IO ()) -- ^ Eat the controller. + -> IO () -animateWithBackendIO backend pannable display backColor frameOp - = do - -- - viewSR <- newIORef viewStateInit - animateSR <- newIORef AN.stateInit - renderS_ <- RS.stateInit - renderSR <- newIORef renderS_ +animateWithBackendIO + backend pannable display backColor + frameOp eatController + = do + -- + viewSR <- newIORef viewStateInit + animateSR <- newIORef AN.stateInit + renderS_ <- initState + renderSR <- newIORef renderS_ - let displayFun backendRef = do - -- extract the current time from the state - timeS <- animateSR `getsIORef` AN.stateAnimateTime + let displayFun backendRef = do + -- extract the current time from the state + timeS <- animateSR `getsIORef` AN.stateAnimateTime - -- call the user action to get the animation frame - picture <- frameOp (double2Float timeS) + -- call the user action to get the animation frame + picture <- frameOp (double2Float timeS) - renderS <- readIORef renderSR - portS <- viewStateViewPort <$> readIORef viewSR + renderS <- readIORef renderSR + portS <- viewStateViewPort <$> readIORef viewSR - -- render the frame - renderAction - backendRef - (renderPicture backendRef renderS portS picture) + windowSize <- getWindowDimensions backendRef - -- perform GC every frame to try and avoid long pauses - performGC + -- render the frame + displayPicture + windowSize + backColor + renderS + (viewPortScale portS) + (applyViewPortToPicture portS picture) - let callbacks - = [ Callback.Display (animateBegin animateSR) - , Callback.Display displayFun - , Callback.Display (animateEnd animateSR) - , Callback.Idle (\s -> postRedisplay s) - , callback_exit () - , callback_viewState_motion viewSR - , callback_viewState_reshape ] - - ++ (if pannable + -- perform GC every frame to try and avoid long pauses + performGC + + let callbacks + = [ Callback.Display (animateBegin animateSR) + , Callback.Display displayFun + , Callback.Display (animateEnd animateSR) + , Callback.Idle (\s -> postRedisplay s) + , callback_exit () + , callback_viewState_motion viewSR + , callback_viewState_reshape ] + + ++ (if pannable then [callback_viewState_keyMouse viewSR] else []) createWindow backend display backColor callbacks + $ \ backendRef + -> eatController + $ Controller + { controllerSetRedraw + = postRedisplay backendRef + + , controllerModifyViewPort + = \modViewPort + -> do viewState <- readIORef viewSR + port' <- modViewPort $ viewStateViewPort viewState + let viewState' = viewState { viewStateViewPort = port' } + writeIORef viewSR viewState' + postRedisplay backendRef + } + + + + getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun diff --git a/Graphics/Gloss/Internals/Interface/Animate/State.hs b/Graphics/Gloss/Internals/Interface/Animate/State.hs --- a/Graphics/Gloss/Internals/Interface/Animate/State.hs +++ b/Graphics/Gloss/Internals/Interface/Animate/State.hs @@ -1,54 +1,54 @@ {-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Animate.State - ( State (..) - , stateInit ) + ( State (..) + , stateInit ) where -- | Animation State data State - = State - { - -- | Whether the animation is running. - stateAnimate :: !Bool + = State + { + -- | Whether the animation is running. + stateAnimate :: !Bool -- | How many times we've entered the animation loop. , stateAnimateCount :: !Integer - -- | Whether this is the first frame of the animation. - , stateAnimateStart :: !Bool + -- | Whether this is the first frame of the animation. + , stateAnimateStart :: !Bool - -- | Number of msec the animation has been running for - , stateAnimateTime :: !Double + -- | Number of msec the animation has been running for + , stateAnimateTime :: !Double - -- | The time when we entered the display callback for the current frame. - , stateDisplayTime :: !Double - , stateDisplayTimeLast :: !Double + -- | The time when we entered the display callback for the current frame. + , stateDisplayTime :: !Double + , stateDisplayTimeLast :: !Double - -- | Clamp the minimum time between frames to this value (in seconds) + -- | Clamp the minimum time between frames to this value (in seconds) -- Setting this to < 10ms probably isn't worthwhile. - , stateDisplayTimeClamp :: !Double - - -- | The time when the last call to the users render function finished. - , stateGateTimeStart :: !Double + , stateDisplayTimeClamp :: !Double - -- | The time when displayInWindow last finished (after sleeping to clamp fps). - , stateGateTimeEnd :: !Double - - -- | How long it took to draw this frame - , stateGateTimeElapsed :: !Double } + -- | The time when the last call to the users render function finished. + , stateGateTimeStart :: !Double + -- | The time when displayInWindow last finished (after sleeping to clamp fps). + , stateGateTimeEnd :: !Double + -- | How long it took to draw this frame + , stateGateTimeElapsed :: !Double } + + stateInit :: State stateInit - = State - { stateAnimate = True + = State + { stateAnimate = True , stateAnimateCount = 0 - , stateAnimateStart = True - , stateAnimateTime = 0 - , stateDisplayTime = 0 - , stateDisplayTimeLast = 0 - , stateDisplayTimeClamp = 0.01 - , stateGateTimeStart = 0 - , stateGateTimeEnd = 0 - , stateGateTimeElapsed = 0 } + , stateAnimateStart = True + , stateAnimateTime = 0 + , stateDisplayTime = 0 + , stateDisplayTimeLast = 0 + , stateDisplayTimeClamp = 0.01 + , stateGateTimeStart = 0 + , stateGateTimeEnd = 0 + , stateGateTimeElapsed = 0 } diff --git a/Graphics/Gloss/Internals/Interface/Animate/Timing.hs b/Graphics/Gloss/Internals/Interface/Animate/Timing.hs --- a/Graphics/Gloss/Internals/Interface/Animate/Timing.hs +++ b/Graphics/Gloss/Internals/Interface/Animate/Timing.hs @@ -2,16 +2,16 @@ {-# OPTIONS_HADDOCK hide #-} -- | Handles timing of animation. --- The main point is that we want to restrict the framerate to something --- sensible, instead of just displaying at the machines maximum possible --- rate and soaking up 100% cpu. +-- The main point is that we want to restrict the framerate to something +-- sensible, instead of just displaying at the machines maximum possible +-- rate and soaking up 100% cpu. -- --- We also keep track of the elapsed time since the start of the program, --- so we can pass this to the user's animation function. --- +-- We also keep track of the elapsed time since the start of the program, +-- so we can pass this to the user's animation function. +-- module Graphics.Gloss.Internals.Interface.Animate.Timing - ( animateBegin - , animateEnd ) + ( animateBegin + , animateEnd ) where import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Animate.State @@ -20,64 +20,68 @@ -- | Handles animation timing details. --- Call this function at the start of each frame. +-- Call this function at the start of each frame. animateBegin :: IORef State -> DisplayCallback animateBegin stateRef backendRef = do - -- write the current time into the display state - displayTime <- elapsedTime backendRef - displayTimeLast <- stateRef `getsIORef` stateDisplayTime - let displayTimeElapsed = displayTime - displayTimeLast + -- write the current time into the display state + displayTime <- elapsedTime backendRef + displayTimeLast <- stateRef `getsIORef` stateDisplayTime + let displayTimeElapsed = displayTime - displayTimeLast - stateRef `modifyIORef` \s -> s - { stateDisplayTime = displayTime - , stateDisplayTimeLast = displayTimeLast } + modifyIORef' stateRef $ \s -> s + { stateDisplayTime = displayTime + , stateDisplayTimeLast = displayTimeLast } - -- increment the animation time - animate <- stateRef `getsIORef` stateAnimate - animateCount <- stateRef `getsIORef` stateAnimateCount - animateTime <- stateRef `getsIORef` stateAnimateTime - animateStart <- stateRef `getsIORef` stateAnimateStart + -- increment the animation time + animate <- stateRef `getsIORef` stateAnimate + animateCount <- stateRef `getsIORef` stateAnimateCount + animateTime <- stateRef `getsIORef` stateAnimateTime + animateStart <- stateRef `getsIORef` stateAnimateStart {- when (animateCount `mod` 5 == 0) $ putStr $ " displayTime = " ++ show displayTime ++ "\n" ++ " displayTimeLast = " ++ show displayTimeLast ++ "\n" ++ " displayTimeElapsed = " ++ show displayTimeElapsed ++ "\n" ++ " fps = " ++ show (truncate $ 1 / displayTimeElapsed) ++ "\n" --} - when (animate && not animateStart) - $ stateRef `modifyIORef` \s -> s - { stateAnimateTime = animateTime + displayTimeElapsed } - - when animate - $ stateRef `modifyIORef` \s -> s - { stateAnimateCount = animateCount + 1 - , stateAnimateStart = False } +-} + when (animate && not animateStart) + $ modifyIORef' stateRef $ \s -> s + { stateAnimateTime = animateTime + displayTimeElapsed } + when animate + $ modifyIORef' stateRef $ \s -> s + { stateAnimateCount = animateCount + 1 + , stateAnimateStart = False } + -- | Handles animation timing details. --- Call this function at the end of each frame. +-- Call this function at the end of each frame. animateEnd :: IORef State -> DisplayCallback animateEnd stateRef backendRef = do - -- timing gate, limits the maximum frame frequency (FPS) - timeClamp <- stateRef `getsIORef` stateDisplayTimeClamp + -- timing gate, limits the maximum frame frequency (FPS) + timeClamp <- stateRef `getsIORef` stateDisplayTimeClamp - gateTimeStart <- elapsedTime backendRef -- the start of this gate - gateTimeEnd <- stateRef `getsIORef` stateGateTimeEnd -- end of the previous gate - let gateTimeElapsed = gateTimeStart - gateTimeEnd + -- the start of this gate + gateTimeStart <- elapsedTime backendRef - when (gateTimeElapsed < timeClamp) - $ do sleep backendRef (timeClamp - gateTimeElapsed) + -- end of the previous gate + gateTimeEnd <- stateRef `getsIORef` stateGateTimeEnd + let gateTimeElapsed = gateTimeStart - gateTimeEnd - gateTimeFinal <- elapsedTime backendRef + when (gateTimeElapsed < timeClamp) + $ do sleep backendRef (timeClamp - gateTimeElapsed) - stateRef `modifyIORef` \s -> s - { stateGateTimeEnd = gateTimeFinal - , stateGateTimeElapsed = gateTimeElapsed } + gateTimeFinal <- elapsedTime backendRef + modifyIORef' stateRef $ \s -> s + { stateGateTimeEnd = gateTimeFinal + , stateGateTimeElapsed = gateTimeElapsed } + getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun = liftM fun $ readIORef ref + diff --git a/Graphics/Gloss/Internals/Interface/Backend.hs b/Graphics/Gloss/Internals/Interface/Backend.hs --- a/Graphics/Gloss/Internals/Interface/Backend.hs +++ b/Graphics/Gloss/Internals/Interface/Backend.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} --- Import window managed backend specific modules. +-- Import window managed backend specific modules. -- We need to use #ifdef here because if the backend library hasn't been installed -- then we won't be able to build it, so it can't be in the import list. module Graphics.Gloss.Internals.Interface.Backend diff --git a/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs b/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs --- a/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs +++ b/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs @@ -6,14 +6,16 @@ (GLFWState) where import Data.IORef -import Data.Char (toLower) +import Data.Maybe (fromJust) +import Control.Concurrent import Control.Monad import Graphics.Gloss.Data.Display -import Graphics.UI.GLFW (WindowValue(..)) import qualified Graphics.UI.GLFW as GLFW +import Graphics.Rendering.OpenGL (($=)) import qualified Graphics.Rendering.OpenGL as GL import qualified Control.Exception as X + -- [Note: FreeGlut] -- ~~~~~~~~~~~~~~~~ -- We use GLUT for font rendering. @@ -21,7 +23,7 @@ -- initialize GLUT before we can use any of it's functions. -- --- We also need to deinitialize (exit) GLUT when we close the GLFW --- window, otherwise opening a gloss window again from GHCi will crash. +-- window, otherwise opening a gloss window again from GHCi will crash. -- For the OS X and Windows version of GLUT there are no such restrictions. -- -- We assume also assume that only linux installations use freeglut. @@ -32,6 +34,7 @@ import Graphics.Gloss.Internals.Interface.Backend.Types + -- | State of the GLFW backend library. data GLFWState = GLFWState @@ -52,6 +55,9 @@ -- | Action perforrmed when idling , idle :: IO () + + -- | The Window Handle + , optWinHdl :: Maybe GLFW.Window } @@ -64,10 +70,18 @@ , mouseWheelPos = 0 , dirtyScreen = True , display = return () - , idle = return () } + , idle = return () + , optWinHdl = Nothing } +-- | Fetch the window handle from the state if it has been initialized. +winHdl :: GLFWState -> GLFW.Window +winHdl state = + case optWinHdl state of + Just handle -> handle + Nothing -> error "GLFW backend: requested uninitialized window handle" + instance Backend GLFWState where initBackendState = glfwStateInit initializeBackend = initializeGLFW @@ -82,19 +96,24 @@ installIdleCallback = installIdleCallbackGLFW runMainLoop = runMainLoopGLFW postRedisplay = postRedisplayGLFW - getWindowDimensions = (\_ -> GLFW.getWindowDimensions) - elapsedTime = (\_ -> GLFW.getTime) - sleep = (\_ sec -> GLFW.sleep sec) - + getWindowDimensions = (\ref -> windowHandle ref >>= \win -> GLFW.getWindowSize win) + getScreenSize = getScreenSizeGLFW + elapsedTime = (\_ -> GLFW.getTime >>= \mt -> return $ fromJust mt) + sleep = (\_ sec -> threadDelay (floor (sec * 1000000.0))) --GLFW.sleep sec) -- Initialise ----------------------------------------------------------------- -- | Initialise the GLFW backend. initializeGLFW :: IORef GLFWState -> Bool-> IO () initializeGLFW _ debug = do - _ <- GLFW.initialize - glfwVersion <- GLFW.getGlfwVersion + let simpleErrorCallback e s = + putStrLn $ unwords [ "GLFW backend: ", show e, show s ] + GLFW.setErrorCallback (Just simpleErrorCallback) + + _ <- GLFW.init + glfwVersion <- GLFW.getVersion + #ifdef linux_HOST_OS -- See [Note: FreeGlut] for why we need this. (_progName, _args) <- GLUT.getArgsAndInitialize @@ -107,73 +126,111 @@ -- Exit ----------------------------------------------------------------------- -- | Tell the GLFW backend to close the window and exit. exitGLFW :: IORef GLFWState -> IO () -exitGLFW _ +exitGLFW ref = do #ifdef linux_HOST_OS -- See [Note: FreeGlut] on why we exit GLUT for Linux GLUT.exit #endif - GLFW.closeWindow + win <- windowHandle ref + GLFW.setWindowShouldClose win True -- Open Window ---------------------------------------------------------------- -- | Open a new window. -openWindowGLFW +openWindowGLFW :: IORef GLFWState -> Display -> IO () -openWindowGLFW _ (InWindow title (sizeX, sizeY) pos) - = do _ <- GLFW.openWindow - GLFW.defaultDisplayOptions - { GLFW.displayOptions_width = sizeX - , GLFW.displayOptions_height = sizeY - , GLFW.displayOptions_displayMode = GLFW.Window } - - uncurry GLFW.setWindowPosition pos - GLFW.setWindowTitle title +openWindowGLFW ref (InWindow title (sizeX, sizeY) pos) + = do win <- GLFW.createWindow + sizeX + sizeY + title + Nothing + Nothing - -- Try to enable sync-to-vertical-refresh by setting the number + modifyIORef' ref (\s -> s { optWinHdl = win }) + uncurry (GLFW.setWindowPos (fromJust win)) pos + GLFW.makeContextCurrent win + + -- Try to enable sync-to-vertical-refresh by setting the number -- of buffer swaps per vertical refresh to 1. - GLFW.setWindowBufferSwapInterval 1 + GLFW.swapInterval 1 -openWindowGLFW _ (FullScreen (sizeX, sizeY)) - = do _ <- GLFW.openWindow - GLFW.defaultDisplayOptions - { GLFW.displayOptions_width = sizeX - , GLFW.displayOptions_height = sizeY - , GLFW.displayOptions_displayMode = GLFW.Fullscreen } - - -- Try to enable sync-to-vertical-refresh by setting the number +openWindowGLFW ref FullScreen + = do mon <- GLFW.getPrimaryMonitor + vmode <- GLFW.getVideoMode (fromJust mon) + + let sizeX = GLFW.videoModeWidth (fromJust vmode) + let sizeY = GLFW.videoModeHeight (fromJust vmode) + + win <- GLFW.createWindow + sizeX + sizeY + "" + mon + Nothing + + modifyIORef' ref (\s -> s { optWinHdl = win}) + GLFW.makeContextCurrent win + + -- Try to enable sync-to-vertical-refresh by setting the number -- of buffer swaps per vertical refresh to 1. - GLFW.setWindowBufferSwapInterval 1 - GLFW.enableMouseCursor + GLFW.swapInterval 1 + --GLFW.enableMouseCursor + GLFW.setCursorInputMode (fromJust win) GLFW.CursorInputMode'Normal + +windowHandle :: IORef GLFWState -> IO GLFW.Window +windowHandle ref + = do s <- readIORef ref + return $ winHdl s + + +getScreenSizeGLFW :: IORef GLFWState -> IO (Int,Int) +getScreenSizeGLFW _state = do + monitor <- GLFW.getPrimaryMonitor + vmode <- GLFW.getVideoMode (fromJust monitor) + + let sizeX = GLFW.videoModeWidth (fromJust vmode) + let sizeY = GLFW.videoModeHeight (fromJust vmode) + + pure (sizeX, sizeY) + + -- Dump State ----------------------------------------------------------------- -- | Print out the internal GLFW state. -dumpStateGLFW :: IORef a -> IO () -dumpStateGLFW _ - = do (ww,wh) <- GLFW.getWindowDimensions +dumpStateGLFW :: IORef GLFWState -> IO () +dumpStateGLFW ref + = do win <- windowHandle ref + (ww,wh) <- GLFW.getWindowSize win - r <- GLFW.getWindowValue NumRedBits - g <- GLFW.getWindowValue NumGreenBits - b <- GLFW.getWindowValue NumBlueBits - a <- GLFW.getWindowValue NumAlphaBits +-- GLFW-b does not provide a general function to query windowHints +-- could be added by adding additional getWindowHint which +-- uses glfwGetWindowAttrib behind the scenes as has been done +-- already for e.g. getWindowVisible which uses glfwGetWindowAttrib +{- + r <- GLFW.getWindowHint NumRedBits + g <- GLFW.getWindowHint NumGreenBits + b <- GLFW.getWindowHint NumBlueBits + a <- GLFW.getWindowHint NumAlphaBits let rgbaBD = [r,g,b,a] - depthBD <- GLFW.getWindowValue NumDepthBits + depthBD <- GLFW.getWindowHint NumDepthBits - ra <- GLFW.getWindowValue NumAccumRedBits - ga <- GLFW.getWindowValue NumAccumGreenBits - ba <- GLFW.getWindowValue NumAccumBlueBits - aa <- GLFW.getWindowValue NumAccumAlphaBits + ra <- GLFW.getWindowHint NumAccumRedBits + ga <- GLFW.getWindowHint NumAccumGreenBits + ba <- GLFW.getWindowHint NumAccumBlueBits + aa <- GLFW.getWindowHint NumAccumAlphaBits let accumBD = [ra,ga,ba,aa] - stencilBD <- GLFW.getWindowValue NumStencilBits + stencilBD <- GLFW.getWindowHint NumStencilBits - auxBuffers <- GLFW.getWindowValue NumAuxBuffers + auxBuffers <- GLFW.getWindowHint NumAuxBuffers - fsaaSamples <- GLFW.getWindowValue NumFsaaSamples + fsaaSamples <- GLFW.getWindowHint NumFsaaSamples putStr $ "* dumpGlfwState\n" ++ " windowWidth = " ++ show ww ++ "\n" @@ -185,7 +242,12 @@ ++ " aux Buffers = " ++ show auxBuffers ++ "\n" ++ " FSAA Samples = " ++ show fsaaSamples ++ "\n" ++ "\n" +-} + putStr $ "* dumpGlfwState\n" + ++ " windowWidth = " ++ show ww ++ "\n" + ++ " windowHeight = " ++ show wh ++ "\n" + ++ "\n" -- Display Callback ----------------------------------------------------------- -- | Callback for when GLFW needs us to redraw the contents of the window. @@ -193,8 +255,8 @@ :: IORef GLFWState -> [Callback] -> IO () installDisplayCallbackGLFW stateRef callbacks - = modifyIORef stateRef - $ \s -> s { display = callbackDisplay stateRef callbacks } + = modifyIORef' stateRef $ \s -> s + { display = callbackDisplay stateRef callbacks } callbackDisplay @@ -206,6 +268,11 @@ GL.clear [GL.ColorBuffer, GL.DepthBuffer] GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat) + -- set the OpenGL viewport to account for any HiDPI discrepancy + (width, height) <- windowHandle stateRef >>= GLFW.getFramebufferSize + GL.viewport $= ( GL.Position 0 0 + , GL.Size (fromIntegral width) (fromIntegral height)) + -- get the display callbacks from the chain let funs = [f stateRef | (Display f) <- callbacks] sequence_ funs @@ -216,35 +283,35 @@ -- Close Callback ------------------------------------------------------------- -- | Callback for when the user closes the window. -- We can do some cleanup here. -installWindowCloseCallbackGLFW +installWindowCloseCallbackGLFW :: IORef GLFWState -> IO () -installWindowCloseCallbackGLFW _ - = GLFW.setWindowCloseCallback - $ do +installWindowCloseCallbackGLFW ref + = do win <- windowHandle ref + GLFW.setWindowCloseCallback win (Just winClosed) + where + winClosed :: GLFW.WindowCloseCallback + winClosed _win = do #ifdef linux_HOST_OS -- See [Note: FreeGlut] for why we need this. GLUT.exit #endif - return True - + return () -- Reshape -------------------------------------------------------------------- -- | Callback for when the user reshapes the window. installReshapeCallbackGLFW - :: Backend a - => IORef a -> [Callback] -> IO () + :: IORef GLFWState -> [Callback] -> IO () installReshapeCallbackGLFW stateRef callbacks - = GLFW.setWindowSizeCallback (callbackReshape stateRef callbacks) + = do win <- windowHandle stateRef + GLFW.setWindowSizeCallback win (Just $ callbackReshape stateRef callbacks) -callbackReshape - :: Backend a - => IORef a -> [Callback] - -> Int -> Int - -> IO () +callbackReshape + :: IORef GLFWState -> [Callback] + -> GLFW.WindowSizeCallback -- = Window -> Int -> Int -> IO () -callbackReshape glfwState callbacks sizeX sizeY +callbackReshape glfwState callbacks _win sizeX sizeY = sequence_ $ map (\f -> f (sizeX, sizeY)) [f glfwState | Reshape f <- callbacks] @@ -255,7 +322,7 @@ -- This is a bit verbose because we have to do impedence matching between -- GLFW's event system, and the one use by Gloss which was originally -- based on GLUT. The main problem is that GLUT only provides a single callback --- slot for character keys, arrow keys, mouse buttons and mouse wheel movement, +-- slot for character keys, arrow keys, mouse buttons and mouse wheel movement, -- while GLFW provides a single slot for each. -- installKeyMouseCallbackGLFW @@ -263,21 +330,24 @@ -> IO () installKeyMouseCallbackGLFW stateRef callbacks - = do GLFW.setKeyCallback $ (callbackKeyboard stateRef callbacks) - GLFW.setCharCallback $ (callbackChar stateRef callbacks) - GLFW.setMouseButtonCallback $ (callbackMouseButton stateRef callbacks) - GLFW.setMouseWheelCallback $ (callbackMouseWheel stateRef callbacks) + = do win <- windowHandle stateRef + GLFW.setKeyCallback win (Just $ callbackKeyboard stateRef callbacks) + GLFW.setCharCallback win (Just $ callbackChar stateRef callbacks) + GLFW.setMouseButtonCallback win (Just $ callbackMouseButton stateRef callbacks) + GLFW.setScrollCallback win (Just $ callbackMouseWheel stateRef callbacks) -- GLFW calls this on a non-character keyboard action. -callbackKeyboard +callbackKeyboard :: IORef GLFWState -> [Callback] - -> GLFW.Key -> Bool - -> IO () + -> GLFW.KeyCallback -- = Window -> Key -> Int -> KeyState -> ModifierKeys -> IO () + -- -> GLFW.Key -> Bool + -- -> IO () -callbackKeyboard stateRef callbacks key keystate - = do (modsSet, GLFWState mods pos _ _ _ _) - <- setModifiers stateRef key keystate +callbackKeyboard stateRef callbacks _win key _scancode keystateglfw _modifiers + = do let keystate = keystateglfw == GLFW.KeyState'Pressed + (modsSet, GLFWState mods pos _ _ _ _ _) + <- setModifiers stateRef key keystate let key' = fromGLFW key let keystate' = if keystate then Down else Up let isCharKey (Char _) = True @@ -285,12 +355,12 @@ -- Call the Gloss KeyMouse actions with the new state. unless (modsSet || isCharKey key' && keystate) - $ sequence_ + $ sequence_ $ map (\f -> f key' keystate' mods pos) [f stateRef | KeyMouse f <- callbacks] -setModifiers +setModifiers :: IORef GLFWState -> GLFW.Key -> Bool -> IO (Bool, GLFWState) @@ -299,10 +369,10 @@ = do glfwState <- readIORef stateRef let mods = modifiers glfwState let mods' = case key of - GLFW.KeyLeftShift -> mods {shift = if pressed then Down else Up} - GLFW.KeyLeftCtrl -> mods {ctrl = if pressed then Down else Up} - GLFW.KeyLeftAlt -> mods {alt = if pressed then Down else Up} - _ -> mods + GLFW.Key'LeftShift -> mods {shift = if pressed then Down else Up} + GLFW.Key'LeftControl -> mods {ctrl = if pressed then Down else Up} + GLFW.Key'LeftAlt -> mods {alt = if pressed then Down else Up} + _ -> mods if (mods' /= mods) then do @@ -313,13 +383,19 @@ -- GLFW calls this on a when the user presses or releases a character key. -callbackChar +callbackChar :: IORef GLFWState -> [Callback] - -> Char -> Bool -> IO () + -> GLFW.CharCallback + -- Window -> Char -> IO () + -- -> Char -> Bool -> IO () -callbackChar stateRef callbacks char keystate - = do (GLFWState mods pos _ _ _ _) <- readIORef stateRef +callbackChar stateRef callbacks _win char -- keystate + = do (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef let key' = charToSpecial char + -- TODO: is this correct? GLFW does not provide the keystate + -- in a character callback, here we asume that its pressed + let keystate = True + -- Only key presses of characters are passed to this callback, -- character key releases are caught by the 'keyCallback'. This is an -- intentional feature of GLFW. What this means that a key press of @@ -329,25 +405,23 @@ let keystate' = if keystate then Down else Up -- Call all the Gloss KeyMouse actions with the new state. - sequence_ - $ map (\f -> f key' keystate' mods pos) + sequence_ + $ map (\f -> f key' keystate' mods pos) [f stateRef | KeyMouse f <- callbacks] -- GLFW calls on this when the user clicks or releases a mouse button. -callbackMouseButton +callbackMouseButton :: IORef GLFWState -> [Callback] - -> GLFW.MouseButton - -> Bool - -> IO () + -> GLFW.MouseButtonCallback -- = Window -> MouseButton -> MouseButtonState -> ModifierKeys -> IO () -callbackMouseButton stateRef callbacks key keystate - = do (GLFWState mods pos _ _ _ _) <- readIORef stateRef +callbackMouseButton stateRef callbacks _win key keystate _modifier + = do (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef let key' = fromGLFW key - let keystate' = if keystate then Down else Up + let keystate' = if keystate == GLFW.MouseButtonState'Pressed then Down else Up -- Call all the Gloss KeyMouse actions with the new state. - sequence_ + sequence_ $ map (\f -> f key' keystate' mods pos) [f stateRef | KeyMouse f <- callbacks] @@ -355,15 +429,16 @@ -- GLFW calls on this when the user moves the mouse wheel. callbackMouseWheel :: IORef GLFWState -> [Callback] - -> Int - -> IO () - -callbackMouseWheel stateRef callbacks w - = do (key, keystate) <- setMouseWheel stateRef w - (GLFWState mods pos _ _ _ _) <- readIORef stateRef + -> GLFW.ScrollCallback + -- -> Int + -- -> IO () +-- ScrollCallback = Window -> Double -> Double -> IO () +callbackMouseWheel stateRef callbacks _win x _y + = do (key, keystate) <- setMouseWheel stateRef (floor x) + (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef -- Call all the Gloss KeyMouse actions with the new state. - sequence_ + sequence_ $ map (\f -> f key keystate mods pos) [f stateRef | KeyMouse f <- callbacks] @@ -383,22 +458,24 @@ -- Motion Callback ------------------------------------------------------------ -- | Callback for when the user moves the mouse. -installMotionCallbackGLFW +installMotionCallbackGLFW :: IORef GLFWState -> [Callback] -> IO () installMotionCallbackGLFW stateRef callbacks - = GLFW.setMousePositionCallback $ (callbackMotion stateRef callbacks) + = do win <- windowHandle stateRef + GLFW.setCursorPosCallback win (Just $ callbackMotion stateRef callbacks) -callbackMotion +--CursorPosCallback = Window -> Double -> Double -> IO () + +callbackMotion :: IORef GLFWState -> [Callback] - -> Int -> Int - -> IO () -callbackMotion stateRef callbacks x y - = do pos <- setMousePos stateRef x y + -> GLFW.CursorPosCallback +callbackMotion stateRef callbacks _win x y + = do pos <- setMousePos stateRef (floor x) (floor y) -- Call all the Gloss Motion actions with the new state. - sequence_ + sequence_ $ map (\f -> f pos) [f stateRef | Motion f <- callbacks] @@ -408,7 +485,10 @@ -> IO (Int, Int) setMousePos stateRef x y = do let pos = (x,y) - modifyIORef stateRef (\s -> s {mousePosition = pos}) + + modifyIORef' stateRef $ \s -> s + { mousePosition = pos } + return pos @@ -419,10 +499,11 @@ :: IORef GLFWState -> [Callback] -> IO () -installIdleCallbackGLFW stateRef callbacks - = modifyIORef stateRef (\s -> s {idle = callbackIdle stateRef callbacks}) +installIdleCallbackGLFW stateRef callbacks + = modifyIORef' stateRef $ \s -> s + { idle = callbackIdle stateRef callbacks } -callbackIdle +callbackIdle :: IORef GLFWState -> [Callback] -> IO () @@ -432,42 +513,65 @@ -- Main Loop ------------------------------------------------------------------ -runMainLoopGLFW - :: IORef GLFWState - -> IO () -runMainLoopGLFW stateRef - = X.catch go exit - where - exit :: X.SomeException -> IO () - exit e = print e >> exitGLFW stateRef +runMainLoopGLFW :: IORef GLFWState -> IO () +runMainLoopGLFW stateRef = do + X.catch go handleException + GLFW.destroyWindow =<< windowHandle stateRef + GLFW.terminate - go :: IO () - go - = do windowIsOpen <- GLFW.windowIsOpen - when windowIsOpen - $ do GLFW.pollEvents - dirty <- fmap dirtyScreen $ readIORef stateRef + where + handleException :: X.SomeException -> IO () + handleException = print - when dirty - $ do s <- readIORef stateRef - display s - GLFW.swapBuffers + clearDirtyFlag :: IO () + clearDirtyFlag = modifyIORef' + stateRef + (\state -> state { dirtyScreen = False }) - modifyIORef stateRef $ \s -> s { dirtyScreen = False } - (readIORef stateRef) >>= (\s -> idle s) - GLFW.sleep 0.001 - runMainLoopGLFW stateRef + display' :: IO () + display' = readIORef stateRef >>= display + idle' :: IO () + idle' = readIORef stateRef >>= idle + swapBuffers' :: IO () + swapBuffers' = windowHandle stateRef >>= GLFW.swapBuffers + + windowShouldClose :: IO Bool + windowShouldClose = windowHandle stateRef >>= GLFW.windowShouldClose + + unlessM :: Monad m => m Bool -> m () -> m () + unlessM testAction action = do + sentinel <- testAction + unless sentinel action + + go :: IO () + go = do + -- Perform drawing, clear the dirty flag, do idle processing + display' + clearDirtyFlag + idle' + + -- Swap buffers. This swaps the GL buffers and will block + -- until the next v-sync. In GLFW, this effectively pegs the + -- maximum frame rate to 60fps, but will also stop the + -- application from consuming 100% CPU. + swapBuffers' + + -- Poll for GLFW events; quit if necessary. + GLFW.pollEvents + unlessM windowShouldClose go + + -- Redisplay ------------------------------------------------------------------ -postRedisplayGLFW +postRedisplayGLFW :: IORef GLFWState -> IO () postRedisplayGLFW stateRef - = modifyIORef stateRef - $ \s -> s { dirtyScreen = True } + = modifyIORef' stateRef $ \s -> s + { dirtyScreen = True } -- Key Code Conversion -------------------------------------------------------- @@ -475,70 +579,95 @@ fromGLFW :: a -> Key instance GLFWKey GLFW.Key where - fromGLFW key + fromGLFW key = case key of - GLFW.CharKey c -> charToSpecial (toLower c) - GLFW.KeySpace -> SpecialKey KeySpace - GLFW.KeyEsc -> SpecialKey KeyEsc - GLFW.KeyF1 -> SpecialKey KeyF1 - GLFW.KeyF2 -> SpecialKey KeyF2 - GLFW.KeyF3 -> SpecialKey KeyF3 - GLFW.KeyF4 -> SpecialKey KeyF4 - GLFW.KeyF5 -> SpecialKey KeyF5 - GLFW.KeyF6 -> SpecialKey KeyF6 - GLFW.KeyF7 -> SpecialKey KeyF7 - GLFW.KeyF8 -> SpecialKey KeyF8 - GLFW.KeyF9 -> SpecialKey KeyF9 - GLFW.KeyF10 -> SpecialKey KeyF10 - GLFW.KeyF11 -> SpecialKey KeyF11 - GLFW.KeyF12 -> SpecialKey KeyF12 - GLFW.KeyF13 -> SpecialKey KeyF13 - GLFW.KeyF14 -> SpecialKey KeyF14 - GLFW.KeyF15 -> SpecialKey KeyF15 - GLFW.KeyF16 -> SpecialKey KeyF16 - GLFW.KeyF17 -> SpecialKey KeyF17 - GLFW.KeyF18 -> SpecialKey KeyF18 - GLFW.KeyF19 -> SpecialKey KeyF19 - GLFW.KeyF20 -> SpecialKey KeyF20 - GLFW.KeyF21 -> SpecialKey KeyF21 - GLFW.KeyF22 -> SpecialKey KeyF22 - GLFW.KeyF23 -> SpecialKey KeyF23 - GLFW.KeyF24 -> SpecialKey KeyF24 - GLFW.KeyF25 -> SpecialKey KeyF25 - GLFW.KeyUp -> SpecialKey KeyUp - GLFW.KeyDown -> SpecialKey KeyDown - GLFW.KeyLeft -> SpecialKey KeyLeft - GLFW.KeyRight -> SpecialKey KeyRight - GLFW.KeyTab -> SpecialKey KeyTab - GLFW.KeyEnter -> SpecialKey KeyEnter - GLFW.KeyBackspace -> SpecialKey KeyBackspace - GLFW.KeyInsert -> SpecialKey KeyInsert - GLFW.KeyDel -> SpecialKey KeyDelete - GLFW.KeyPageup -> SpecialKey KeyPageUp - GLFW.KeyPagedown -> SpecialKey KeyPageDown - GLFW.KeyHome -> SpecialKey KeyHome - GLFW.KeyEnd -> SpecialKey KeyEnd - GLFW.KeyPad0 -> SpecialKey KeyPad0 - GLFW.KeyPad1 -> SpecialKey KeyPad1 - GLFW.KeyPad2 -> SpecialKey KeyPad2 - GLFW.KeyPad3 -> SpecialKey KeyPad3 - GLFW.KeyPad4 -> SpecialKey KeyPad4 - GLFW.KeyPad5 -> SpecialKey KeyPad5 - GLFW.KeyPad6 -> SpecialKey KeyPad6 - GLFW.KeyPad7 -> SpecialKey KeyPad7 - GLFW.KeyPad8 -> SpecialKey KeyPad8 - GLFW.KeyPad9 -> SpecialKey KeyPad9 - GLFW.KeyPadDivide -> SpecialKey KeyPadDivide - GLFW.KeyPadMultiply -> SpecialKey KeyPadMultiply - GLFW.KeyPadSubtract -> SpecialKey KeyPadSubtract - GLFW.KeyPadAdd -> SpecialKey KeyPadAdd - GLFW.KeyPadDecimal -> SpecialKey KeyPadDecimal - GLFW.KeyPadEqual -> Char '=' - GLFW.KeyPadEnter -> SpecialKey KeyPadEnter - _ -> SpecialKey KeyUnknown + GLFW.Key'A -> charToSpecial 'a' + GLFW.Key'B -> charToSpecial 'b' + GLFW.Key'C -> charToSpecial 'c' + GLFW.Key'D -> charToSpecial 'd' + GLFW.Key'E -> charToSpecial 'e' + GLFW.Key'F -> charToSpecial 'f' + GLFW.Key'G -> charToSpecial 'g' + GLFW.Key'H -> charToSpecial 'h' + GLFW.Key'I -> charToSpecial 'i' + GLFW.Key'J -> charToSpecial 'j' + GLFW.Key'K -> charToSpecial 'k' + GLFW.Key'L -> charToSpecial 'l' + GLFW.Key'M -> charToSpecial 'm' + GLFW.Key'N -> charToSpecial 'n' + GLFW.Key'O -> charToSpecial 'o' + GLFW.Key'P -> charToSpecial 'p' + GLFW.Key'Q -> charToSpecial 'q' + GLFW.Key'R -> charToSpecial 'r' + GLFW.Key'S -> charToSpecial 's' + GLFW.Key'T -> charToSpecial 't' + GLFW.Key'U -> charToSpecial 'u' + GLFW.Key'V -> charToSpecial 'v' + GLFW.Key'W -> charToSpecial 'w' + GLFW.Key'X -> charToSpecial 'x' + GLFW.Key'Y -> charToSpecial 'y' + GLFW.Key'Z -> charToSpecial 'z' + GLFW.Key'Space -> SpecialKey KeySpace + GLFW.Key'Escape -> SpecialKey KeyEsc + GLFW.Key'F1 -> SpecialKey KeyF1 + GLFW.Key'F2 -> SpecialKey KeyF2 + GLFW.Key'F3 -> SpecialKey KeyF3 + GLFW.Key'F4 -> SpecialKey KeyF4 + GLFW.Key'F5 -> SpecialKey KeyF5 + GLFW.Key'F6 -> SpecialKey KeyF6 + GLFW.Key'F7 -> SpecialKey KeyF7 + GLFW.Key'F8 -> SpecialKey KeyF8 + GLFW.Key'F9 -> SpecialKey KeyF9 + GLFW.Key'F10 -> SpecialKey KeyF10 + GLFW.Key'F11 -> SpecialKey KeyF11 + GLFW.Key'F12 -> SpecialKey KeyF12 + GLFW.Key'F13 -> SpecialKey KeyF13 + GLFW.Key'F14 -> SpecialKey KeyF14 + GLFW.Key'F15 -> SpecialKey KeyF15 + GLFW.Key'F16 -> SpecialKey KeyF16 + GLFW.Key'F17 -> SpecialKey KeyF17 + GLFW.Key'F18 -> SpecialKey KeyF18 + GLFW.Key'F19 -> SpecialKey KeyF19 + GLFW.Key'F20 -> SpecialKey KeyF20 + GLFW.Key'F21 -> SpecialKey KeyF21 + GLFW.Key'F22 -> SpecialKey KeyF22 + GLFW.Key'F23 -> SpecialKey KeyF23 + GLFW.Key'F24 -> SpecialKey KeyF24 + GLFW.Key'F25 -> SpecialKey KeyF25 + GLFW.Key'Up -> SpecialKey KeyUp + GLFW.Key'Down -> SpecialKey KeyDown + GLFW.Key'Left -> SpecialKey KeyLeft + GLFW.Key'Right -> SpecialKey KeyRight + GLFW.Key'Tab -> SpecialKey KeyTab + GLFW.Key'Enter -> SpecialKey KeyEnter + GLFW.Key'Backspace -> SpecialKey KeyBackspace + GLFW.Key'Insert -> SpecialKey KeyInsert + GLFW.Key'Delete -> SpecialKey KeyDelete + GLFW.Key'PageUp -> SpecialKey KeyPageUp + GLFW.Key'PageDown -> SpecialKey KeyPageDown + GLFW.Key'Home -> SpecialKey KeyHome + GLFW.Key'End -> SpecialKey KeyEnd + GLFW.Key'Pad0 -> SpecialKey KeyPad0 + GLFW.Key'Pad1 -> SpecialKey KeyPad1 + GLFW.Key'Pad2 -> SpecialKey KeyPad2 + GLFW.Key'Pad3 -> SpecialKey KeyPad3 + GLFW.Key'Pad4 -> SpecialKey KeyPad4 + GLFW.Key'Pad5 -> SpecialKey KeyPad5 + GLFW.Key'Pad6 -> SpecialKey KeyPad6 + GLFW.Key'Pad7 -> SpecialKey KeyPad7 + GLFW.Key'Pad8 -> SpecialKey KeyPad8 + GLFW.Key'Pad9 -> SpecialKey KeyPad9 + GLFW.Key'PadDivide -> SpecialKey KeyPadDivide + GLFW.Key'PadMultiply -> SpecialKey KeyPadMultiply + GLFW.Key'PadSubtract -> SpecialKey KeyPadSubtract + GLFW.Key'PadAdd -> SpecialKey KeyPadAdd + GLFW.Key'PadDecimal -> SpecialKey KeyPadDecimal + GLFW.Key'PadEqual -> Char '=' + GLFW.Key'PadEnter -> SpecialKey KeyPadEnter + _ -> SpecialKey KeyUnknown --- | Convert char keys to special keys to work around a bug in +-- | Convert char keys to special keys to work around a bug in -- GLFW 2.7. On OS X, GLFW sometimes registers special keys as char keys, -- so we convert them back here. -- GLFW 2.7 is current as of Nov 2011, and is shipped with the Hackage @@ -573,11 +702,11 @@ instance GLFWKey GLFW.MouseButton where fromGLFW mouse = case mouse of - GLFW.MouseButton0 -> MouseButton LeftButton - GLFW.MouseButton1 -> MouseButton RightButton - GLFW.MouseButton2 -> MouseButton MiddleButton - GLFW.MouseButton3 -> MouseButton $ AdditionalButton 3 - GLFW.MouseButton4 -> MouseButton $ AdditionalButton 4 - GLFW.MouseButton5 -> MouseButton $ AdditionalButton 5 - GLFW.MouseButton6 -> MouseButton $ AdditionalButton 6 - GLFW.MouseButton7 -> MouseButton $ AdditionalButton 7 + GLFW.MouseButton'1 -> MouseButton LeftButton + GLFW.MouseButton'2 -> MouseButton RightButton + GLFW.MouseButton'3 -> MouseButton MiddleButton + GLFW.MouseButton'4 -> MouseButton $ AdditionalButton 4 + GLFW.MouseButton'5 -> MouseButton $ AdditionalButton 5 + GLFW.MouseButton'6 -> MouseButton $ AdditionalButton 6 + GLFW.MouseButton'7 -> MouseButton $ AdditionalButton 7 + GLFW.MouseButton'8 -> MouseButton $ AdditionalButton 8 diff --git a/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs b/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs --- a/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs +++ b/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs @@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Backend.GLUT - (GLUTState) + (GLUTState,glutStateInit,initializeGLUT) where import Data.IORef @@ -11,15 +11,39 @@ import qualified Graphics.UI.GLUT as GLUT import qualified System.Exit as System import Graphics.Gloss.Internals.Interface.Backend.Types +import System.IO.Unsafe +-- Were we to support freeglut only, we could use GLUT.get to discover +-- whether we are initialized or not. If not, we do a quick initialize, +-- get the screenzie, and then do GLUT.exit. This avoids the use of +-- global variables. Unfortunately, there is no failsafe way to check +-- whether glut is initialized in some older versions of glut, which is +-- what we'd use instead of the global variable to get the required info. +glutInitialized :: IORef Bool +{-# NOINLINE glutInitialized #-} +glutInitialized = unsafePerformIO $ do newIORef False --- | We don't maintain any state information for the GLUT backend, --- so this data type is empty. -data GLUTState +-- | State information for the GLUT backend. +data GLUTState = GLUTState + { -- Count of total number of frames that we have drawn. + glutStateFrameCount :: !Int + -- Bool to remember if we've set the timeout callback. + , glutStateHasTimeout :: Bool + + -- Bool to remember if we've set the idle callback. + , glutStateHasIdle :: Bool } + deriving Show + + +-- | Initial GLUT state. glutStateInit :: GLUTState -glutStateInit = GLUTState +glutStateInit + = GLUTState + { glutStateFrameCount = 0 + , glutStateHasTimeout = False + , glutStateHasIdle = False } instance Backend GLUTState where @@ -54,6 +78,10 @@ = do GL.Size sizeX sizeY <- get GLUT.windowSize return (fromEnum sizeX,fromEnum sizeY) + getScreenSize _ + = do GL.Size width height <- get GLUT.screenSize + return (fromIntegral width, fromIntegral height) + elapsedTime _ = do t <- get GLUT.elapsedTime return $ (fromIntegral t) / 1000 @@ -68,25 +96,28 @@ -> Bool -> IO () -initializeGLUT _ debug - = do (_progName, _args) <- GLUT.getArgsAndInitialize - - glutVersion <- get GLUT.glutVersion - when debug - $ putStr $ " glutVersion = " ++ show glutVersion ++ "\n" +initializeGLUT _ debug + = do initialized <- readIORef glutInitialized + if not initialized + then do (_progName, _args) <- GLUT.getArgsAndInitialize + glutVersion <- get GLUT.glutVersion + when debug + $ putStr $ " glutVersion = " ++ show glutVersion ++ "\n" - GLUT.initialDisplayMode - $= [ GLUT.RGBMode - , GLUT.DoubleBuffered] + GLUT.initialDisplayMode + $= [ GLUT.RGBMode + , GLUT.DoubleBuffered] - -- See if our requested display mode is possible - displayMode <- get GLUT.initialDisplayMode - displayModePossible <- get GLUT.displayModePossible - when debug - $ do putStr $ " displayMode = " ++ show displayMode ++ "\n" - ++ " possible = " ++ show displayModePossible ++ "\n" - ++ "\n" + writeIORef glutInitialized True + -- See if our requested display mode is possible + displayMode <- get GLUT.initialDisplayMode + displayModePossible <- get GLUT.displayModePossible + when debug + $ do putStr $ " displayMode = " ++ show displayMode ++ "\n" + ++ " possible = " ++ show displayModePossible ++ "\n" + ++ "\n" + else when debug (putStrLn "Already initialized") -- Open Window ---------------------------------------------------------------- openWindowGLUT @@ -101,7 +132,7 @@ -- createWindow. If we don't do this we get wierd half-created -- windows some of the time. case display of - InWindow windowName (sizeX, sizeY) (posX, posY) -> + InWindow windowName (sizeX, sizeY) (posX, posY) -> do GLUT.initialWindowSize $= GL.Size (fromIntegral sizeX) @@ -119,11 +150,11 @@ (fromIntegral sizeX) (fromIntegral sizeY) - FullScreen (sizeX, sizeY) -> - do GLUT.gameModeCapabilities $= - [ GLUT.Where' GLUT.GameModeWidth GLUT.IsEqualTo sizeX - , GLUT.Where' GLUT.GameModeHeight GLUT.IsEqualTo sizeY ] - void $ GLUT.enterGameMode + FullScreen -> + do size <- get GLUT.screenSize + GLUT.initialWindowSize $= size + _ <- GLUT.createWindow "Gloss Application" + GLUT.fullScreen -- Switch some things. -- auto repeat interferes with key up / key down checks. @@ -132,11 +163,11 @@ -- Dump State ----------------------------------------------------------------- -dumpStateGLUT +dumpStateGLUT :: IORef GLUTState -> IO () -dumpStateGLUT _ +dumpStateGLUT _ = do wbw <- get GLUT.windowBorderWidth whh <- get GLUT.windowHeaderHeight @@ -168,34 +199,85 @@ ++ "\n" -- Display Callback ----------------------------------------------------------- -installDisplayCallbackGLUT +installDisplayCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () installDisplayCallbackGLUT ref callbacks = GLUT.displayCallback $= callbackDisplay ref callbacks -callbackDisplay + +callbackDisplay :: IORef GLUTState -> [Callback] -> IO () -callbackDisplay ref callbacks - = do -- clear the display +callbackDisplay refState callbacks + = do + -- Clear the display GL.clear [GL.ColorBuffer, GL.DepthBuffer] GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat) - -- get the display callbacks from the chain - let funs = [f ref | (Display f) <- callbacks] + -- Run all the display callbacks to draw the window contents. + let funs = [f refState | (Display f) <- callbacks] sequence_ funs - -- swap front and back buffers + -- Swap front and back buffers GLUT.swapBuffers + -- Timeout. + -- When there is no idle callback set the GLUT mainloop will block + -- forever waiting for display events. This prevents us from updating + -- the display on external events like files changing. The API doesn't + -- provide a way to wake it up on these other events. + -- + -- Set a timeout so that GLUT will return from its mainloop after a + -- a second and give us a chance to check for other events. + -- + -- The alternative would be to set an Idle callback and spin the CPU. + -- This is ok for real-time animations, but a CPU hog for mostly static + -- displays. + -- + -- We only want to add a timeout when one doesn't already exist, + -- otherwise we'll get both events. + -- + state <- readIORef refState + when ( (not $ glutStateHasTimeout state) + && (not $ glutStateHasIdle state)) + $ do + -- Setting the timer interrupt to 1sec keeps CPU usage for a + -- single process to < 0.5% or so on OSX. This is the rate + -- that the process is woken up, but GLUT will only actually + -- call the display call if postRedisplay has been set. + let msecHeartbeat = 1000 + + -- We're installing this callback on the first display + -- call because it's a GLUT specific mechanism. + -- We don't do the same thing for other Backends. + GLUT.addTimerCallback msecHeartbeat + $ timerCallback msecHeartbeat + + -- Rember that we've done this filthy hack. + atomicModifyIORef' refState + $ \s -> (s { glutStateHasTimeout = True }, ()) + + -- Don't report errors by default. - -- The windows OpenGL implementation seems to complain for no reason. + -- The windows OpenGL implementation seems to complain for no reason. -- GLUT.reportErrors + atomicModifyIORef' refState + $ \s -> ( s { glutStateFrameCount = glutStateFrameCount s + 1 } + , ()) + return () + +-- | Oneshot timer callback that re-registers itself. +timerCallback :: Int -> IO () +timerCallback msec + = do GLUT.addTimerCallback msec + $ do timerCallback msec + + -- Reshape Callback ----------------------------------------------------------- installReshapeCallbackGLUT :: IORef GLUTState -> [Callback] @@ -216,7 +298,7 @@ -- KeyMouse Callback ---------------------------------------------------------- -installKeyMouseCallbackGLUT +installKeyMouseCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () @@ -243,7 +325,7 @@ -- Motion Callback ------------------------------------------------------------ -installMotionCallbackGLUT +installMotionCallbackGLUT :: IORef GLUTState -> [Callback] -> IO () @@ -268,10 +350,21 @@ :: IORef GLUTState -> [Callback] -> IO () -installIdleCallbackGLUT ref callbacks - = GLUT.idleCallback $= Just (callbackIdle ref callbacks) +installIdleCallbackGLUT refState callbacks + -- If the callback list does not actually contain an idle callback + -- then don't install one that just does nothing. If we do then GLUT + -- will still call us back after whenever it's idle and waste CPU time. + | any isIdleCallback callbacks + = do GLUT.idleCallback $= Just (callbackIdle refState callbacks) + atomicModifyIORef' refState + $ \state -> (state { glutStateHasIdle = True }, ()) -callbackIdle + | otherwise + = return () + + +-- | Call back when glut is idle. +callbackIdle :: IORef GLUTState -> [Callback] -> IO () @@ -283,7 +376,7 @@ ------------------------------------------------------------------------------- -- | Convert GLUTs key codes to our internal ones. glutKeyToKey :: GLUT.Key -> Key -glutKeyToKey key +glutKeyToKey key = case key of GLUT.Char '\32' -> SpecialKey KeySpace GLUT.Char '\13' -> SpecialKey KeyEnter @@ -338,11 +431,11 @@ -- | Convert GLUTs key states to our internal ones. -glutModifiersToModifiers +glutModifiersToModifiers :: GLUT.Modifiers -> Modifiers - -glutModifiersToModifiers (GLUT.Modifiers a b c) + +glutModifiersToModifiers (GLUT.Modifiers a b c) = Modifiers (glutKeyStateToKeyState a) (glutKeyStateToKeyState b) (glutKeyStateToKeyState c) diff --git a/Graphics/Gloss/Internals/Interface/Backend/Types.hs b/Graphics/Gloss/Internals/Interface/Backend/Types.hs --- a/Graphics/Gloss/Internals/Interface/Backend/Types.hs +++ b/Graphics/Gloss/Internals/Interface/Backend/Types.hs @@ -64,6 +64,9 @@ -- | Function that returns (width,height) of the window in pixels. getWindowDimensions :: IORef a -> IO (Int,Int) + -- | Function that returns (width,height) of a fullscreen window in pixels. + getScreenSize :: IORef a -> IO (Int,Int) + -- | Function that reports the time elapsed since the application started. -- (in seconds) elapsedTime :: IORef a -> IO Double @@ -77,21 +80,27 @@ -- can thus call the appropriate backend functions. -- | Display callback has no arguments. -type DisplayCallback = forall a . Backend a => IORef a -> IO () +type DisplayCallback + = forall a . Backend a => IORef a -> IO () -- | Arguments: KeyType, Key Up \/ Down, Ctrl \/ Alt \/ Shift pressed, latest mouse location. -type KeyboardMouseCallback = forall a . Backend a => IORef a -> Key -> KeyState -> Modifiers -> (Int,Int) -> IO () +type KeyboardMouseCallback + = forall a . Backend a => IORef a -> Key -> KeyState -> Modifiers -> (Int,Int) -> IO () -- | Arguments: (PosX,PosY) in pixels. -type MotionCallback = forall a . Backend a => IORef a -> (Int,Int) -> IO () +type MotionCallback + = forall a . Backend a => IORef a -> (Int,Int) -> IO () -- | No arguments. -type IdleCallback = forall a . Backend a => IORef a -> IO () +type IdleCallback + = forall a . Backend a => IORef a -> IO () -- | Arguments: (Width,Height) in pixels. -type ReshapeCallback = forall a . Backend a => IORef a -> (Int,Int) -> IO () +type ReshapeCallback + = forall a . Backend a => IORef a -> (Int,Int) -> IO () +------------------------------------------------------------------------------- data Callback = Display DisplayCallback | KeyMouse KeyboardMouseCallback @@ -99,11 +108,20 @@ | Motion MotionCallback | Reshape ReshapeCallback + +-- | Check if this is an `Idle` callback. +isIdleCallback :: Callback -> Bool +isIdleCallback cc + = case cc of + Idle _ -> True + _ -> False + + ------------------------------------------------------------------------------- -- This is Glosses view of mouse and keyboard events. -- The actual events provided by the backends are converted to this form -- by the backend module. - + data Key = Char Char | SpecialKey SpecialKey @@ -193,10 +211,11 @@ | KeyPadEnter deriving (Show, Eq, Ord) + data Modifiers = Modifiers { shift :: KeyState , ctrl :: KeyState - , alt :: KeyState - } + , alt :: KeyState } deriving (Show, Eq, Ord) + diff --git a/Graphics/Gloss/Internals/Interface/Common/Exit.hs b/Graphics/Gloss/Internals/Interface/Common/Exit.hs --- a/Graphics/Gloss/Internals/Interface/Common/Exit.hs +++ b/Graphics/Gloss/Internals/Interface/Common/Exit.hs @@ -1,25 +1,26 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE PatternGuards, RankNTypes #-} -- | Callback for exiting the program. module Graphics.Gloss.Internals.Interface.Common.Exit - (callback_exit) + (callback_exit) where import Graphics.Gloss.Internals.Interface.Backend.Types callback_exit :: a -> Callback callback_exit stateRef - = KeyMouse (keyMouse_exit stateRef) + = KeyMouse (keyMouse_exit stateRef) keyMouse_exit :: a -> KeyboardMouseCallback keyMouse_exit - _ - backend - key keyState _ - _ - | key == SpecialKey KeyEsc - , keyState == Down - = exitBackend backend - - | otherwise - = return () + _ + backend + key keyState _ + _ + | key == SpecialKey KeyEsc + , keyState == Down + = exitBackend backend + + | otherwise + = return () diff --git a/Graphics/Gloss/Internals/Interface/Debug.hs b/Graphics/Gloss/Internals/Interface/Debug.hs --- a/Graphics/Gloss/Internals/Interface/Debug.hs +++ b/Graphics/Gloss/Internals/Interface/Debug.hs @@ -1,67 +1,67 @@ {-# OPTIONS_HADDOCK hide #-} -- | Implements functions to dump portions of the OpenGL state to stdout. --- Used for debugging. +-- Used for debugging. module Graphics.Gloss.Internals.Interface.Debug - ( dumpFramebufferState - , dumpFragmentState ) + ( dumpFramebufferState + , dumpFragmentState ) where -import qualified Graphics.Rendering.OpenGL.GL as GL -import Graphics.Rendering.OpenGL (get) - +import qualified Graphics.Rendering.OpenGL.GL as GL +import Graphics.Rendering.OpenGL (get) + -- | Dump internal state of the OpenGL framebuffer dumpFramebufferState :: IO () dumpFramebufferState = do - auxBuffers <- get GL.auxBuffers - doubleBuffer <- get GL.doubleBuffer - drawBuffer <- get GL.drawBuffer + auxBuffers <- get GL.auxBuffers + doubleBuffer <- get GL.doubleBuffer + drawBuffer <- get GL.drawBuffer - rgbaBits <- get GL.rgbaBits - stencilBits <- get GL.stencilBits - depthBits <- get GL.depthBits - accumBits <- get GL.accumBits - - clearColor <- get GL.clearColor - clearStencil <- get GL.clearStencil - clearDepth <- get GL.clearDepth - clearAccum <- get GL.clearAccum - - colorMask <- get GL.colorMask - stencilMask <- get GL.stencilMask - depthMask <- get GL.depthMask - - putStr $ "* dumpFramebufferState\n" - ++ " auxBuffers = " ++ show auxBuffers ++ "\n" - ++ " doubleBuffer = " ++ show doubleBuffer ++ "\n" - ++ " drawBuffer = " ++ show drawBuffer ++ "\n" - ++ "\n" - ++ " bits rgba = " ++ show rgbaBits ++ "\n" - ++ " stencil = " ++ show stencilBits ++ "\n" - ++ " depth = " ++ show depthBits ++ "\n" - ++ " accum = " ++ show accumBits ++ "\n" - ++ "\n" - ++ " clear color = " ++ show clearColor ++ "\n" - ++ " stencil = " ++ show clearStencil ++ "\n" - ++ " depth = " ++ show clearDepth ++ "\n" - ++ " accum = " ++ show clearAccum ++ "\n" - ++ "\n" - ++ " mask color = " ++ show colorMask ++ "\n" - ++ " stencil = " ++ show stencilMask ++ "\n" - ++ " depth = " ++ show depthMask ++ "\n" - ++ "\n" - + rgbaBits <- get GL.rgbaBits + stencilBits <- get GL.stencilBits + depthBits <- get GL.depthBits + accumBits <- get GL.accumBits + clearColor <- get GL.clearColor + clearStencil <- get GL.clearStencil + clearDepth <- get GL.clearDepth + clearAccum <- get GL.clearAccum + + colorMask <- get GL.colorMask + stencilMask <- get GL.stencilMask + depthMask <- get GL.depthMask + + putStr $ "* dumpFramebufferState\n" + ++ " auxBuffers = " ++ show auxBuffers ++ "\n" + ++ " doubleBuffer = " ++ show doubleBuffer ++ "\n" + ++ " drawBuffer = " ++ show drawBuffer ++ "\n" + ++ "\n" + ++ " bits rgba = " ++ show rgbaBits ++ "\n" + ++ " stencil = " ++ show stencilBits ++ "\n" + ++ " depth = " ++ show depthBits ++ "\n" + ++ " accum = " ++ show accumBits ++ "\n" + ++ "\n" + ++ " clear color = " ++ show clearColor ++ "\n" + ++ " stencil = " ++ show clearStencil ++ "\n" + ++ " depth = " ++ show clearDepth ++ "\n" + ++ " accum = " ++ show clearAccum ++ "\n" + ++ "\n" + ++ " mask color = " ++ show colorMask ++ "\n" + ++ " stencil = " ++ show stencilMask ++ "\n" + ++ " depth = " ++ show depthMask ++ "\n" + ++ "\n" + + -- | Dump internal state of the fragment renderer. dumpFragmentState :: IO () dumpFragmentState = do - blend <- get GL.blend - blendEquation <- get GL.blendEquation - blendFunc <- get GL.blendFunc - - putStr $ "* dumpFragmentState\n" - ++ " blend = " ++ show blend ++ "\n" - ++ " blend equation = " ++ show blendEquation ++ "\n" - ++ " blend func = " ++ show blendFunc ++ "\n" - ++ "\n" + blend <- get GL.blend + blendEquation <- get GL.blendEquation + blendFunc <- get GL.blendFunc + + putStr $ "* dumpFragmentState\n" + ++ " blend = " ++ show blend ++ "\n" + ++ " blend equation = " ++ show blendEquation ++ "\n" + ++ " blend func = " ++ show blendFunc ++ "\n" + ++ "\n" diff --git a/Graphics/Gloss/Internals/Interface/Display.hs b/Graphics/Gloss/Internals/Interface/Display.hs --- a/Graphics/Gloss/Internals/Interface/Display.hs +++ b/Graphics/Gloss/Internals/Interface/Display.hs @@ -1,55 +1,86 @@ module Graphics.Gloss.Internals.Interface.Display - (displayWithBackend) -where + (displayWithBackend) +where import Graphics.Gloss.Data.Color +import Graphics.Gloss.Data.Controller import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Data.ViewState -import Graphics.Gloss.Internals.Render.Common -import Graphics.Gloss.Internals.Render.Picture +import Graphics.Gloss.Rendering import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit import Graphics.Gloss.Internals.Interface.ViewState.KeyMouse import Graphics.Gloss.Internals.Interface.ViewState.Motion import Graphics.Gloss.Internals.Interface.ViewState.Reshape -import qualified Graphics.Gloss.Internals.Render.State as RS -import qualified Graphics.Gloss.Internals.Interface.Callback as Callback - +import qualified Graphics.Gloss.Internals.Interface.Callback as Callback import Data.IORef -import Data.Functor +import System.Mem displayWithBackend - :: Backend a - => a -- ^ Initial state of the backend. - -> Display -- ^ Display config. - -> Color -- ^ Background color. - -> Picture -- ^ The picture to draw. - -> IO () + :: Backend a + => a -- ^ Initial state of the backend. + -> Display -- ^ Display config. + -> Color -- ^ Background color. + -> IO Picture -- ^ Make the picture to draw. + -> (Controller -> IO ()) -- ^ Eat the controller + -> IO () -displayWithBackend backend displayMode background picture - = do viewSR <- newIORef viewStateInit +displayWithBackend + backend displayMode background + makePicture + eatController - renderS <- RS.stateInit - renderSR <- newIORef renderS - - let renderFun backendRef = do - port <- viewStateViewPort <$> readIORef viewSR - options <- readIORef renderSR - renderAction - backendRef - (renderPicture backendRef options port picture) + = do viewSR <- newIORef viewStateInit + renderS <- initState + renderSR <- newIORef renderS - let callbacks - = [ Callback.Display renderFun + let renderFun backendRef = do + port <- viewStateViewPort <$> readIORef viewSR + options <- readIORef renderSR + windowSize <- getWindowDimensions backendRef + picture <- makePicture - -- Escape exits the program - , callback_exit () - - -- Viewport control with mouse - , callback_viewState_keyMouse viewSR - , callback_viewState_motion viewSR - , callback_viewState_reshape ] + displayPicture + windowSize + background + options + (viewPortScale port) + (applyViewPortToPicture port picture) - createWindow backend displayMode background callbacks + -- perform GC every frame to try and avoid long pauses + performGC + + let callbacks + = [ Callback.Display renderFun + + -- Escape exits the program + , callback_exit () + + -- Viewport control with mouse + , callback_viewState_keyMouse viewSR + , callback_viewState_motion viewSR + , callback_viewState_reshape ] + + -- When we create the window we can pass a function to get a + -- reference to the backend state. Using this we make a controller + -- so the client can control the window asynchronously. + createWindow backend displayMode background callbacks + $ \ backendRef + -> eatController + $ Controller + { controllerSetRedraw + = do postRedisplay backendRef + + , controllerModifyViewPort + = \modViewPort + -> do viewState <- readIORef viewSR + port' <- modViewPort $ viewStateViewPort viewState + let viewState' = viewState { viewStateViewPort = port' } + writeIORef viewSR viewState' + postRedisplay backendRef + } + + diff --git a/Graphics/Gloss/Internals/Interface/Event.hs b/Graphics/Gloss/Internals/Interface/Event.hs --- a/Graphics/Gloss/Internals/Interface/Event.hs +++ b/Graphics/Gloss/Internals/Interface/Event.hs @@ -1,53 +1,52 @@ {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Event ( Event (..) - , keyMouseEvent - , motionEvent ) + , keyMouseEvent + , motionEvent ) where import Data.IORef -import Data.Functor ((<$>)) import Graphics.Gloss.Internals.Interface.Backend -- | Possible input events. data Event - = EventKey Key KeyState Modifiers (Float, Float) - | EventMotion (Float, Float) + = EventKey Key KeyState Modifiers (Float, Float) + | EventMotion (Float, Float) | EventResize (Int, Int) - deriving (Eq, Show) + deriving (Eq, Show) keyMouseEvent :: - forall a . Backend a - => IORef a - -> Key - -> KeyState - -> Modifiers - -> (Int, Int) - -> IO Event + forall a . Backend a + => IORef a + -> Key + -> KeyState + -> Modifiers + -> (Int, Int) + -> IO Event keyMouseEvent backendRef key keyState modifiers pos - = EventKey key keyState modifiers <$> convertPoint backendRef pos + = EventKey key keyState modifiers <$> convertPoint backendRef pos motionEvent :: - forall a . Backend a - => IORef a - -> (Int, Int) - -> IO Event + forall a . Backend a + => IORef a + -> (Int, Int) + -> IO Event motionEvent backendRef pos - = EventMotion <$> convertPoint backendRef pos + = EventMotion <$> convertPoint backendRef pos convertPoint :: - forall a . Backend a - => IORef a - -> (Int, Int) - -> IO (Float,Float) + forall a . Backend a + => IORef a + -> (Int, Int) + -> IO (Float,Float) convertPoint backendRef pos - = do (sizeX_, sizeY_) <- getWindowDimensions backendRef - let (sizeX, sizeY) = (fromIntegral sizeX_, fromIntegral sizeY_) + = do (sizeX_, sizeY_) <- getWindowDimensions backendRef + let (sizeX, sizeY) = (fromIntegral sizeX_, fromIntegral sizeY_) - let (px_, py_) = pos - let px = fromIntegral px_ - let py = sizeY - fromIntegral py_ - - let px' = px - sizeX / 2 - let py' = py - sizeY / 2 - let pos' = (px', py') - return pos' + let (px_, py_) = pos + let px = fromIntegral px_ + let py = sizeY - fromIntegral py_ + + let px' = px - sizeX / 2 + let py' = py - sizeY / 2 + let pos' = (px', py') + return pos' diff --git a/Graphics/Gloss/Internals/Interface/Game.hs b/Graphics/Gloss/Internals/Interface/Game.hs --- a/Graphics/Gloss/Internals/Interface/Game.hs +++ b/Graphics/Gloss/Internals/Interface/Game.hs @@ -1,14 +1,13 @@ {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Game - ( playWithBackendIO - , Event(..) ) + ( playWithBackendIO + , Event(..) ) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.ViewPort -import Graphics.Gloss.Internals.Render.Common -import Graphics.Gloss.Internals.Render.Picture +import Graphics.Gloss.Rendering import Graphics.Gloss.Internals.Interface.Event import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window @@ -16,108 +15,121 @@ import Graphics.Gloss.Internals.Interface.ViewState.Reshape import Graphics.Gloss.Internals.Interface.Animate.Timing import Graphics.Gloss.Internals.Interface.Simulate.Idle -import qualified Graphics.Gloss.Internals.Interface.Callback as Callback -import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM -import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN -import qualified Graphics.Gloss.Internals.Render.State as RS +import qualified Graphics.Gloss.Internals.Interface.Callback as Callback +import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM +import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN import Data.IORef import System.Mem playWithBackendIO - :: forall world a - . Backend a - => a -- ^ Initial state of the backend - -> 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 Picture) -- ^ A function to convert the world to 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. - -> Bool -- ^ Whether to use the callback_exit or not. - -> IO () + :: forall world a + . Backend a + => a -- ^ Initial state of the backend + -> 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 Picture) + -- ^ A function to convert the world to 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. + -> Bool -- ^ Whether to use the callback_exit or not. + -> IO () playWithBackendIO - backend + backend display - backgroundColor - simResolution - worldStart - worldToPicture - worldHandleEvent - worldAdvance - withCallbackExit + backgroundColor + simResolution + worldStart + worldToPicture + worldHandleEvent + worldAdvance + withCallbackExit = do - let singleStepTime = 1 + let singleStepTime = 1 - -- make the simulation state - stateSR <- newIORef $ SM.stateInit simResolution + -- make the simulation state + stateSR <- newIORef $ SM.stateInit simResolution - -- make a reference to the initial world - worldSR <- newIORef worldStart + -- make a reference to the initial world + worldSR <- newIORef worldStart - -- make the initial GL view and render states - viewSR <- newIORef viewPortInit - animateSR <- newIORef AN.stateInit - renderS_ <- RS.stateInit - renderSR <- newIORef renderS_ + -- make the initial GL view and render states + viewSR <- newIORef viewPortInit + animateSR <- newIORef AN.stateInit + renderS_ <- initState + renderSR <- newIORef renderS_ - let displayFun backendRef - = do - -- convert the world to a picture - world <- readIORef worldSR - picture <- worldToPicture world - - -- display the picture in the current view - renderS <- readIORef renderSR - viewS <- readIORef viewSR + let displayFun backendRef + = do + -- convert the world to a picture + world <- readIORef worldSR + picture <- worldToPicture world - -- render the frame - renderAction - backendRef - (renderPicture backendRef renderS viewS picture) - - -- perform garbage collection - performGC + -- display the picture in the current view + renderS <- readIORef renderSR + viewPort <- readIORef viewSR - let callbacks - = [ Callback.Display (animateBegin animateSR) - , Callback.Display displayFun - , Callback.Display (animateEnd animateSR) - , Callback.Idle (callback_simulate_idle - stateSR animateSR (readIORef viewSR) - worldSR worldStart (\_ -> worldAdvance) - singleStepTime) - , callback_keyMouse worldSR viewSR worldHandleEvent - , callback_motion worldSR worldHandleEvent - , callback_reshape worldSR worldHandleEvent] + windowSize <- getWindowDimensions backendRef - let exitCallback - = if withCallbackExit then [callback_exit ()] else [] + -- render the frame + displayPicture + windowSize + backgroundColor + renderS + (viewPortScale viewPort) + (applyViewPortToPicture viewPort picture) - createWindow backend display backgroundColor $ callbacks ++ exitCallback + -- perform GC every frame to try and avoid long pauses + performGC + let callbacks + = [ Callback.Display (animateBegin animateSR) + , Callback.Display displayFun + , Callback.Display (animateEnd animateSR) + , Callback.Idle (callback_simulate_idle + stateSR animateSR (readIORef viewSR) + worldSR (\_ -> worldAdvance) + singleStepTime) + , callback_keyMouse worldSR viewSR worldHandleEvent + , callback_motion worldSR worldHandleEvent + , callback_reshape worldSR worldHandleEvent] + let exitCallback + = if withCallbackExit then [callback_exit ()] else [] + + createWindow + backend + display + backgroundColor + (callbacks ++ exitCallback) + (\_ -> return ()) + + + -- | Callback for KeyMouse events. -callback_keyMouse - :: IORef world -- ^ ref to world state - -> IORef ViewPort - -> (Event -> world -> IO world) -- ^ fn to handle input events - -> Callback +callback_keyMouse + :: IORef world -- ^ ref to world state + -> IORef ViewPort + -> (Event -> world -> IO world) -- ^ fn to handle input events + -> Callback callback_keyMouse worldRef viewRef eventFn - = KeyMouse (handle_keyMouse worldRef viewRef eventFn) + = KeyMouse (handle_keyMouse worldRef viewRef eventFn) -handle_keyMouse - :: IORef a - -> t - -> (Event -> a -> IO a) - -> KeyboardMouseCallback +handle_keyMouse + :: IORef a + -> t + -> (Event -> a -> IO a) + -> KeyboardMouseCallback handle_keyMouse worldRef _ eventFn backendRef key keyState keyMods pos - = do ev <- keyMouseEvent backendRef key keyState keyMods pos + = do ev <- keyMouseEvent backendRef key keyState keyMods pos world <- readIORef worldRef world' <- eventFn ev world writeIORef worldRef world' @@ -125,18 +137,18 @@ -- | Callback for Motion events. callback_motion - :: IORef world -- ^ ref to world state - -> (Event -> world -> IO world) -- ^ fn to handle input events - -> Callback + :: IORef world -- ^ ref to world state + -> (Event -> world -> IO world) -- ^ fn to handle input events + -> Callback callback_motion worldRef eventFn - = Motion (handle_motion worldRef eventFn) + = Motion (handle_motion worldRef eventFn) -handle_motion - :: IORef a - -> (Event -> a -> IO a) - -> MotionCallback +handle_motion + :: IORef a + -> (Event -> a -> IO a) + -> MotionCallback handle_motion worldRef eventFn backendRef pos = do ev <- motionEvent backendRef pos @@ -151,7 +163,7 @@ -> (Event -> world -> IO world) -> Callback callback_reshape worldRef eventFN - = Reshape (handle_reshape worldRef eventFN) + = Reshape (handle_reshape worldRef eventFN) handle_reshape diff --git a/Graphics/Gloss/Internals/Interface/Interact.hs b/Graphics/Gloss/Internals/Interface/Interact.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Internals/Interface/Interact.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE RankNTypes #-} + +module Graphics.Gloss.Internals.Interface.Interact + (interactWithBackend) +where +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Data.Controller +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.ViewPort +import Graphics.Gloss.Data.ViewState +import Graphics.Gloss.Rendering +import Graphics.Gloss.Internals.Interface.Event +import Graphics.Gloss.Internals.Interface.Backend +import Graphics.Gloss.Internals.Interface.Window +import Graphics.Gloss.Internals.Interface.ViewState.Reshape +import qualified Graphics.Gloss.Internals.Interface.Callback as Callback +import Data.IORef +import System.Mem + + +interactWithBackend + :: Backend a + => a -- ^ Initial state of the backend. + -> Display -- ^ Display config. + -> Color -- ^ Background color. + -> world -- ^ The initial world. + -> (world -> IO Picture) -- ^ A function to produce the current picture. + -> (Event -> world -> IO world) -- ^ A function to handle input events. + -> (Controller -> IO ()) -- ^ Eat the controller + -> IO () + +interactWithBackend + backend displayMode background + worldStart + worldToPicture + worldHandleEvent + eatController + + = do viewSR <- newIORef viewStateInit + worldSR <- newIORef worldStart + renderS <- initState + renderSR <- newIORef renderS + + let displayFun backendRef = do + world <- readIORef worldSR + picture <- worldToPicture world + + renderS' <- readIORef renderSR + viewState <- readIORef viewSR + let viewPort = viewStateViewPort viewState + + windowSize <- getWindowDimensions backendRef + + displayPicture + windowSize + background + renderS' + (viewPortScale viewPort) + (applyViewPortToPicture viewPort picture) + + -- perform GC every frame to try and avoid long pauses + performGC + + let callbacks + = [ Callback.Display displayFun + + -- Viewport control with mouse + , callback_keyMouse worldSR viewSR worldHandleEvent + , callback_motion worldSR worldHandleEvent + , callback_reshape worldSR worldHandleEvent ] + + -- When we create the window we can pass a function to get a + -- reference to the backend state. Using this we make a controller + -- so the client can control the window asynchronously. + createWindow backend displayMode background callbacks + $ \ backendRef + -> eatController + $ Controller + { controllerSetRedraw + = do postRedisplay backendRef + + , controllerModifyViewPort + = \modViewPort + -> do viewState <- readIORef viewSR + port' <- modViewPort $ viewStateViewPort viewState + let viewState' = viewState { viewStateViewPort = port' } + writeIORef viewSR viewState' + postRedisplay backendRef + } + + +-- | Callback for KeyMouse events. +callback_keyMouse + :: IORef world -- ^ ref to world state + -> IORef ViewState + -> (Event -> world -> IO world) -- ^ fn to handle input events + -> Callback + +callback_keyMouse worldRef viewRef eventFn + = KeyMouse (handle_keyMouse worldRef viewRef eventFn) + + +handle_keyMouse + :: IORef a + -> t + -> (Event -> a -> IO a) + -> KeyboardMouseCallback + +handle_keyMouse worldRef _ eventFn backendRef key keyState keyMods pos + = do ev <- keyMouseEvent backendRef key keyState keyMods pos + world <- readIORef worldRef + world' <- eventFn ev world + writeIORef worldRef world' + postRedisplay backendRef + + +-- | Callback for Motion events. +callback_motion + :: IORef world -- ^ ref to world state + -> (Event -> world -> IO world) -- ^ fn to handle input events + -> Callback + +callback_motion worldRef eventFn + = Motion (handle_motion worldRef eventFn) + + +handle_motion + :: IORef a + -> (Event -> a -> IO a) + -> MotionCallback + +handle_motion worldRef eventFn backendRef pos + = do ev <- motionEvent backendRef pos + world <- readIORef worldRef + world' <- eventFn ev world + writeIORef worldRef world' + postRedisplay backendRef + + +-- | Callback for Handle reshape event. +callback_reshape + :: IORef world + -> (Event -> world -> IO world) + -> Callback + +callback_reshape worldRef eventFN + = Reshape (handle_reshape worldRef eventFN) + + +handle_reshape + :: IORef world + -> (Event -> world -> IO world) + -> ReshapeCallback +handle_reshape worldRef eventFn backendRef (width,height) + = do world <- readIORef worldRef + world' <- eventFn (EventResize (width, height)) world + writeIORef worldRef world' + viewState_reshape backendRef (width, height) + postRedisplay backendRef + diff --git a/Graphics/Gloss/Internals/Interface/Simulate.hs b/Graphics/Gloss/Internals/Interface/Simulate.hs --- a/Graphics/Gloss/Internals/Interface/Simulate.hs +++ b/Graphics/Gloss/Internals/Interface/Simulate.hs @@ -1,14 +1,14 @@ {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Simulate - (simulateWithBackendIO) + (simulateWithBackendIO) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Data.ViewState -import Graphics.Gloss.Internals.Render.Common -import Graphics.Gloss.Internals.Render.Picture +import Graphics.Gloss.Rendering import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Window import Graphics.Gloss.Internals.Interface.Common.Exit @@ -17,82 +17,91 @@ import Graphics.Gloss.Internals.Interface.ViewState.Reshape import Graphics.Gloss.Internals.Interface.Animate.Timing import Graphics.Gloss.Internals.Interface.Simulate.Idle -import qualified Graphics.Gloss.Internals.Interface.Callback as Callback -import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM -import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN -import qualified Graphics.Gloss.Internals.Render.State as RS -import Data.Functor ((<$>)) +import qualified Graphics.Gloss.Internals.Interface.Callback as Callback +import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM +import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN import Data.IORef import System.Mem simulateWithBackendIO - :: forall model a - . Backend a - => a -- ^ Initial state of the backend - -> Display -- ^ Display mode. - -> Color -- ^ Background color. - -> Int -- ^ Number of simulation steps to take for each second of real time. - -> model -- ^ The initial model. - -> (model -> IO Picture) -- ^ A function to convert the model to a picture. - -> (ViewPort -> Float -> model -> IO model) -- ^ A function to step the model one iteration. It is passed the - -- current viewport and the amount of time for this simulation - -- step (in seconds). - -> IO () + :: forall model a + . Backend a + => a -- ^ Initial state of the backend + -> Display -- ^ Display mode. + -> Color -- ^ Background color. + -> Int -- ^ Number of simulation steps to take for each second of real time. + -> model -- ^ The initial model. + -> (model -> IO Picture) + -- ^ A function to convert the model to a picture. + -> (ViewPort -> Float -> model -> IO model) + -- ^ A function to step the model one iteration. It is passed the + -- current viewport and the amount of time for this simulation + -- step (in seconds). + -> IO () simulateWithBackendIO - backend + backend display - backgroundColor - simResolution - worldStart - worldToPicture - worldAdvance + backgroundColor + simResolution + worldStart + worldToPicture + worldAdvance = do - let singleStepTime = 1 + let singleStepTime = 1 - -- make the simulation state - stateSR <- newIORef $ SM.stateInit simResolution + -- make the simulation state + stateSR <- newIORef $ SM.stateInit simResolution - -- make a reference to the initial world - worldSR <- newIORef worldStart + -- make a reference to the initial world + worldSR <- newIORef worldStart - -- make the initial GL view and render states - viewSR <- newIORef viewStateInit - animateSR <- newIORef AN.stateInit - renderS_ <- RS.stateInit - renderSR <- newIORef renderS_ + -- make the initial GL view and render states + viewSR <- newIORef viewStateInit + animateSR <- newIORef AN.stateInit + renderS_ <- initState + renderSR <- newIORef renderS_ - let displayFun backendRef - = do - -- convert the world to a picture - world <- readIORef worldSR - port <- viewStateViewPort <$> readIORef viewSR - picture <- worldToPicture world + let displayFun backendRef + = do + -- convert the world to a picture + world <- readIORef worldSR + port <- viewStateViewPort <$> readIORef viewSR + picture <- worldToPicture world - -- display the picture in the current view - renderS <- readIORef renderSR + -- display the picture in the current view + renderS <- readIORef renderSR - -- render the frame - renderAction - backendRef - (renderPicture backendRef renderS port picture) - - -- perform garbage collection - performGC + windowSize <- getWindowDimensions backendRef - let callbacks - = [ Callback.Display (animateBegin animateSR) - , Callback.Display displayFun - , Callback.Display (animateEnd animateSR) - , Callback.Idle (callback_simulate_idle - stateSR animateSR - (viewStateViewPort <$> readIORef viewSR) - worldSR worldStart worldAdvance - singleStepTime) - , callback_exit () - , callback_viewState_keyMouse viewSR - , callback_viewState_motion viewSR - , callback_viewState_reshape ] + -- render the frame + displayPicture + windowSize + backgroundColor + renderS + (viewPortScale port) + (applyViewPortToPicture port picture) - createWindow backend display backgroundColor callbacks + -- perform GC every frame to try and avoid long pauses + performGC + + let callbacks + = [ Callback.Display (animateBegin animateSR) + , Callback.Display displayFun + , Callback.Display (animateEnd animateSR) + , Callback.Idle (callback_simulate_idle + stateSR animateSR + (viewStateViewPort <$> readIORef viewSR) + worldSR worldAdvance + singleStepTime) + , callback_exit () + , callback_viewState_keyMouse viewSR + , callback_viewState_motion viewSR + , callback_viewState_reshape ] + + createWindow backend display backgroundColor + callbacks + (const (return ())) + + diff --git a/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs b/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs --- a/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs +++ b/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs @@ -2,150 +2,100 @@ {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Simulate.Idle - ( callback_simulate_idle ) + ( callback_simulate_idle ) where import Graphics.Gloss.Data.ViewPort import Graphics.Gloss.Internals.Interface.Callback -import qualified Graphics.Gloss.Internals.Interface.Backend as Backend -import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN -import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM +import qualified Graphics.Gloss.Internals.Interface.Backend as Backend +import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN +import qualified Graphics.Gloss.Internals.Interface.Simulate.State as SM import Data.IORef import Control.Monad import GHC.Float (double2Float) -- | The graphics library calls back on this function when it's finished drawing --- and it's time to do some computation. +-- and it's time to do some computation. callback_simulate_idle - :: IORef SM.State -- ^ the simulation state - -> IORef AN.State -- ^ the animation statea - -> IO ViewPort + :: IORef SM.State -- ^ the simulation state + -> IORef AN.State -- ^ the animation statea + -> IO ViewPort -- ^ action to get the 'ViewPort'. We don't use an 'IORef' -- directly because sometimes we hold a ref to a 'ViewPort' (in -- Game) and sometimes a ref to a 'ViewState'. - -> IORef world -- ^ the current world - -> world -- ^ the initial world - -> (ViewPort -> Float -> world -> IO world) -- ^ fn to advance the world - -> Float -- ^ how much time to advance world by - -- in single step mode - -> IdleCallback - -callback_simulate_idle simSR animateSR viewSA worldSR worldStart worldAdvance singleStepTime backendRef + -> IORef world -- ^ the current world + -> (ViewPort -> Float -> world -> IO world) -- ^ fn to advance the world + -> Float -- ^ how much time to advance world by + -- in single step mode + -> IdleCallback + +callback_simulate_idle simSR animateSR viewSA worldSR worldAdvance _singleStepTime backendRef = {-# SCC "callbackIdle" #-} - do simS <- readIORef simSR - let result - | SM.stateReset simS - = simulate_reset simSR worldSR worldStart + do simulate_run simSR animateSR viewSA worldSR worldAdvance backendRef - | SM.stateRun simS - = simulate_run simSR animateSR viewSA worldSR worldAdvance - - | SM.stateStep simS - = simulate_step simSR viewSA worldSR worldAdvance singleStepTime - - | otherwise - = \_ -> return () - - result backendRef - --- reset the world to -simulate_reset :: IORef SM.State -> IORef a -> a -> IdleCallback -simulate_reset simSR worldSR worldStart backendRef - = do writeIORef worldSR worldStart - - simSR `modifyIORef` \c -> c - { SM.stateReset = False - , SM.stateIteration = 0 - , SM.stateSimTime = 0 } - - Backend.postRedisplay backendRef - - -- take the number of steps specified by controlWarp -simulate_run - :: IORef SM.State - -> IORef AN.State - -> IO ViewPort - -> IORef world - -> (ViewPort -> Float -> world -> IO world) - -> IdleCallback - +simulate_run + :: IORef SM.State + -> IORef AN.State + -> IO ViewPort + -> IORef world + -> (ViewPort -> Float -> world -> IO world) + -> IdleCallback + simulate_run simSR _ viewSA worldSR worldAdvance backendRef - = do viewS <- viewSA - simS <- readIORef simSR - worldS <- readIORef worldSR + = do viewS <- viewSA + simS <- readIORef simSR + worldS <- readIORef worldSR - -- get the elapsed time since the start simulation (wall clock) - elapsedTime <- fmap double2Float $ Backend.elapsedTime backendRef + -- get the elapsed time since the start simulation (wall clock) + elapsedTime <- fmap double2Float $ Backend.elapsedTime backendRef - -- get how far along the simulation is - simTime <- simSR `getsIORef` SM.stateSimTime - - -- we want to simulate this much extra time to bring the simulation - -- up to the wall clock. - let thisTime = elapsedTime - simTime - - -- work out how many steps of simulation this equals - resolution <- simSR `getsIORef` SM.stateResolution - let timePerStep = 1 / fromIntegral resolution - let thisSteps_ = truncate $ fromIntegral resolution * thisTime - let thisSteps = if thisSteps_ < 0 then 0 else thisSteps_ + -- get how far along the simulation is + simTime <- simSR `getsIORef` SM.stateSimTime - let newSimTime = simTime + fromIntegral thisSteps * timePerStep - -{- putStr $ "elapsed time = " ++ show elapsedTime ++ "\n" - ++ "sim time = " ++ show simTime ++ "\n" - ++ "this time = " ++ show thisTime ++ "\n" - ++ "this steps = " ++ show thisSteps ++ "\n" - ++ "new sim time = " ++ show newSimTime ++ "\n" - ++ "taking = " ++ show thisSteps ++ "\n\n" --} - -- work out the final step number for this display cycle - let nStart = SM.stateIteration simS - let nFinal = nStart + thisSteps + -- we want to simulate this much extra time to bring the simulation + -- up to the wall clock. + let thisTime = elapsedTime - simTime - -- keep advancing the world until we get to the final iteration number - (_,world') <- untilM (\(n, _) -> n >= nFinal) - (\(n, w) -> liftM (\w' -> (n+1,w')) ( worldAdvance viewS timePerStep w)) - (nStart, worldS) + -- work out how many steps of simulation this equals + resolution <- simSR `getsIORef` SM.stateResolution + let timePerStep = 1 / fromIntegral resolution + let thisSteps_ = truncate $ fromIntegral resolution * thisTime + let thisSteps = if thisSteps_ < 0 then 0 else thisSteps_ - -- write the world back into its IORef - -- We need to seq on the world to avoid space leaks when the window is not showing. - world' `seq` writeIORef worldSR world' + let newSimTime = simTime + fromIntegral thisSteps * timePerStep - -- update the control state - simSR `modifyIORef` \c -> c - { SM.stateIteration = nFinal - , SM.stateSimTime = newSimTime - , SM.stateStepsPerFrame = fromIntegral thisSteps } - - -- tell glut we want to draw the window after returning - Backend.postRedisplay backendRef +{- putStr $ "elapsed time = " ++ show elapsedTime ++ "\n" + ++ "sim time = " ++ show simTime ++ "\n" + ++ "this time = " ++ show thisTime ++ "\n" + ++ "this steps = " ++ show thisSteps ++ "\n" + ++ "new sim time = " ++ show newSimTime ++ "\n" + ++ "taking = " ++ show thisSteps ++ "\n\n" +-} + -- work out the final step number for this display cycle + let nStart = SM.stateIteration simS + let nFinal = nStart + thisSteps + -- keep advancing the world until we get to the final iteration number + (_,world') + <- untilM (\(n, _) -> n >= nFinal) + (\(n, w) -> liftM (\w' -> (n+1,w')) ( worldAdvance viewS timePerStep w)) + (nStart, worldS) --- take a single step -simulate_step - :: IORef SM.State - -> IO ViewPort - -> IORef world - -> (ViewPort -> Float -> world -> IO world) - -> Float - -> IdleCallback + -- write the world back into its IORef + -- We need to seq on the world to avoid space leaks when the window is not showing. + world' `seq` writeIORef worldSR world' -simulate_step simSR viewSA worldSR worldAdvance singleStepTime backendRef - = do viewS <- viewSA - world <- readIORef worldSR - world' <- worldAdvance viewS singleStepTime world - - writeIORef worldSR world' - simSR `modifyIORef` \c -> c - { SM.stateIteration = SM.stateIteration c + 1 - , SM.stateStep = False } - - Backend.postRedisplay backendRef + -- update the control state + modifyIORef' simSR $ \c -> c + { SM.stateIteration = nFinal + , SM.stateSimTime = newSimTime } + -- tell glut we want to draw the window after returning + Backend.postRedisplay backendRef + getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun = liftM fun $ readIORef ref @@ -155,4 +105,4 @@ where go x | test x = return x | otherwise = op x >>= go - + diff --git a/Graphics/Gloss/Internals/Interface/Simulate/State.hs b/Graphics/Gloss/Internals/Interface/Simulate/State.hs --- a/Graphics/Gloss/Internals/Interface/Simulate/State.hs +++ b/Graphics/Gloss/Internals/Interface/Simulate/State.hs @@ -1,45 +1,29 @@ {-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Simulate.State - ( State (..) - , stateInit ) + ( State (..) + , stateInit ) where -- | Simulation state -data State - = State - { -- | The iteration number we're up to. - stateIteration :: !Integer +data State + = State + { -- | The iteration number we're up to. + stateIteration :: !Integer - -- | Whether the animation is free-running (or single step) - , stateRun :: !Bool + -- | How many simulation setps to take for each second of real time + , stateResolution :: !Int - -- | Signals to callbackIdle to take a single step of the automation. - , stateStep :: !Bool + -- | How many seconds worth of simulation we've done so far + , stateSimTime :: !Float } - -- | Signals to callbackIdle to roll-back to the initial world. - , stateReset :: !Bool - - -- | How many simulation setps to take for each second of real time - , stateResolution :: !Int - - -- | How many seconds worth of simulation we've done so far - , stateSimTime :: !Float - - -- | Record how many steps we've been taking per frame - , stateStepsPerFrame :: !Int } - -- | Initial control state stateInit :: Int -> State stateInit resolution - = State - { stateIteration = 0 - , stateRun = True - , stateStep = False - , stateReset = False - , stateResolution = resolution - , stateSimTime = 0 - , stateStepsPerFrame = 0 } - - + = State + { stateIteration = 0 + , stateResolution = resolution + , stateSimTime = 0 } + + diff --git a/Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs b/Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs --- a/Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs +++ b/Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.ViewState.KeyMouse - (callback_viewState_keyMouse) + (callback_viewState_keyMouse) where import Graphics.Gloss.Data.ViewState import Graphics.Gloss.Internals.Interface.Backend @@ -11,22 +11,22 @@ -- | Callback to handle keyboard and mouse button events --- for controlling the 'ViewState'. -callback_viewState_keyMouse - :: IORef ViewState - -> Callback +-- for controlling the 'ViewState'. +callback_viewState_keyMouse + :: IORef ViewState + -> Callback callback_viewState_keyMouse viewStateRef - = KeyMouse (viewState_keyMouse viewStateRef) + = KeyMouse (viewState_keyMouse viewStateRef) viewState_keyMouse :: IORef ViewState -> KeyboardMouseCallback viewState_keyMouse viewStateRef stateRef key keyState keyMods pos - = do viewState <- readIORef viewStateRef - ev <- keyMouseEvent stateRef key keyState keyMods pos + = do viewState <- readIORef viewStateRef + ev <- keyMouseEvent stateRef key keyState keyMods pos case updateViewStateWithEventMaybe ev viewState of - Nothing -> return () - Just viewState' - -> do viewStateRef `writeIORef` viewState' - postRedisplay stateRef + Nothing -> return () + Just viewState' + -> do viewStateRef `writeIORef` viewState' + postRedisplay stateRef diff --git a/Graphics/Gloss/Internals/Interface/ViewState/Motion.hs b/Graphics/Gloss/Internals/Interface/ViewState/Motion.hs --- a/Graphics/Gloss/Internals/Interface/ViewState/Motion.hs +++ b/Graphics/Gloss/Internals/Interface/ViewState/Motion.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE ScopedTypeVariables, RankNTypes #-} module Graphics.Gloss.Internals.Interface.ViewState.Motion - (callback_viewState_motion) + (callback_viewState_motion) where import Graphics.Gloss.Data.ViewState import Graphics.Gloss.Internals.Interface.Callback @@ -12,23 +13,23 @@ -- | Callback to handle keyboard and mouse button events --- for controlling the viewport. -callback_viewState_motion - :: IORef ViewState - -> Callback +-- for controlling the viewport. +callback_viewState_motion + :: IORef ViewState + -> Callback callback_viewState_motion portRef - = Motion (viewState_motion portRef) + = Motion (viewState_motion portRef) viewState_motion :: IORef ViewState -> MotionCallback viewState_motion viewStateRef stateRef pos - = do viewState <- readIORef viewStateRef - ev <- motionEvent stateRef pos + = do viewState <- readIORef viewStateRef + ev <- motionEvent stateRef pos case updateViewStateWithEventMaybe ev viewState of - Nothing -> return () - Just viewState' - -> do viewStateRef `writeIORef` viewState' - postRedisplay stateRef + Nothing -> return () + Just viewState' + -> do viewStateRef `writeIORef` viewState' + postRedisplay stateRef diff --git a/Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs b/Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs --- a/Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs +++ b/Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs @@ -1,28 +1,28 @@ {-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.ViewState.Reshape - (callback_viewState_reshape, viewState_reshape) + (callback_viewState_reshape, viewState_reshape) where import Graphics.Gloss.Internals.Interface.Callback import Graphics.Gloss.Internals.Interface.Backend -import Graphics.Rendering.OpenGL (($=)) -import qualified Graphics.Rendering.OpenGL.GL as GL +import Graphics.Rendering.OpenGL (($=)) +import qualified Graphics.Rendering.OpenGL.GL as GL -- | Callback to handle keyboard and mouse button events --- for controlling the viewport. +-- for controlling the viewport. callback_viewState_reshape :: Callback callback_viewState_reshape - = Reshape (viewState_reshape) + = Reshape (viewState_reshape) viewState_reshape :: ReshapeCallback viewState_reshape stateRef (width,height) = do - -- Setup the viewport - -- This controls what part of the window openGL renders to. - -- We'll use the whole window. - -- - GL.viewport $= ( GL.Position 0 0 + -- Setup the viewport + -- This controls what part of the window openGL renders to. + -- We'll use the whole window. + -- + GL.viewport $= ( GL.Position 0 0 , GL.Size (fromIntegral width) (fromIntegral height)) - postRedisplay stateRef + postRedisplay stateRef diff --git a/Graphics/Gloss/Internals/Interface/Window.hs b/Graphics/Gloss/Internals/Interface/Window.hs --- a/Graphics/Gloss/Internals/Interface/Window.hs +++ b/Graphics/Gloss/Internals/Interface/Window.hs @@ -1,79 +1,83 @@ {-# OPTIONS_HADDOCK hide #-} --- | The main display function. -module Graphics.Gloss.Internals.Interface.Window - ( createWindow ) +-- | The main display function. +module Graphics.Gloss.Internals.Interface.Window + ( createWindow ) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Internals.Color import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Debug -import Graphics.Rendering.OpenGL (($=)) -import qualified Graphics.Rendering.OpenGL.GL as GL -import Data.IORef (newIORef) +import Graphics.Rendering.OpenGL (($=)) +import qualified Graphics.Rendering.OpenGL.GL as GL +import Data.IORef (IORef, newIORef) import Control.Monad -- | Open a window and use the supplied callbacks to handle window events. createWindow - :: Backend a - => a + :: Backend a + => a -> Display - -> Color -- ^ Color to use when clearing. - -> [Callback] -- ^ Callbacks to use - -> IO () + -> Color -- ^ Color to use when clearing. + -> [Callback] -- ^ Callbacks to use. + -> (IORef a -> IO ()) -- ^ Give the backend back to the caller before + -- entering the main loop. + -> IO () createWindow - backend + backend display - clearColor - callbacks + clearColor + callbacks + eatBackend = do - -- Turn this on to spew debugging info to stdout - let debug = False + -- Turn this on to spew debugging info to stdout + let debug = False - -- Initialize backend state - backendStateRef <- newIORef backend + -- Initialize backend state + backendStateRef <- newIORef backend - when debug - $ do putStr $ "* displayInWindow\n" + when debug + $ do putStr $ "* displayInWindow\n" - -- Intialize backend - initializeBackend backendStateRef debug + -- Intialize backend + initializeBackend backendStateRef debug - -- Here we go! - when debug - $ do putStr $ "* c window\n\n" + -- Here we go! + when debug + $ do putStr $ "* c window\n\n" - -- Open window - openWindow backendStateRef display + -- Open window + openWindow backendStateRef display - -- Setup callbacks - installDisplayCallback backendStateRef callbacks - installWindowCloseCallback backendStateRef - installReshapeCallback backendStateRef callbacks - installKeyMouseCallback backendStateRef callbacks - installMotionCallback backendStateRef callbacks - installIdleCallback backendStateRef callbacks + -- Setup callbacks + installDisplayCallback backendStateRef callbacks + installWindowCloseCallback backendStateRef + installReshapeCallback backendStateRef callbacks + installKeyMouseCallback backendStateRef callbacks + installMotionCallback backendStateRef callbacks + installIdleCallback backendStateRef callbacks - -- we don't need the depth buffer for 2d. - GL.depthFunc $= Just GL.Always + -- we don't need the depth buffer for 2d. + GL.depthFunc $= Just GL.Always - -- always clear the buffer to white - GL.clearColor $= glColor4OfColor clearColor + -- always clear the buffer to white + GL.clearColor $= glColor4OfColor clearColor - -- Dump some debugging info - when debug - $ do dumpBackendState backendStateRef - dumpFramebufferState - dumpFragmentState + -- Dump some debugging info + when debug + $ do dumpBackendState backendStateRef + dumpFramebufferState + dumpFragmentState - when debug - $ do putStr $ "* entering mainloop..\n" + eatBackend backendStateRef - -- Start the main backend loop - runMainLoop backendStateRef + when debug + $ do putStr $ "* entering mainloop..\n" - when debug - $ putStr $ "* all done\n" + -- Start the main backend loop + runMainLoop backendStateRef - return () + when debug + $ putStr $ "* all done\n" + diff --git a/Graphics/Gloss/Internals/Render/Bitmap.hs b/Graphics/Gloss/Internals/Render/Bitmap.hs deleted file mode 100644 --- a/Graphics/Gloss/Internals/Render/Bitmap.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# OPTIONS -fwarn-incomplete-patterns #-} - --- | Helper functions for rendering bitmaps -module Graphics.Gloss.Internals.Render.Bitmap - ( BitmapData(..) - , reverseRGBA - , bitmapPath - , freeBitmapData - ) -where -import Data.Data -import Foreign - - --- | Abstract 32-bit RGBA bitmap data. -data BitmapData - = BitmapData - Int -- length (in bytes) - (ForeignPtr Word8) -- pointer to data - deriving (Eq, Data, Typeable) - - -instance Show BitmapData where - show _ = "BitmapData" - - --- | Generates the point path to display the bitmap centred -bitmapPath :: Float -> Float -> [(Float, Float)] -bitmapPath width height - = [(-width', -height'), (width', -height'), (width', height'), (-width', height')] - where width' = width / 2 - height' = height / 2 - - --- | Destructively reverse the byte order in an array. --- This is necessary as OpenGL reads pixel data as ABGR, rather than RGBA -reverseRGBA :: BitmapData -> IO () -reverseRGBA (BitmapData length8 fptr) - = withForeignPtr fptr (reverseRGBA_ptr length8) - - --- | Destructively reverses the byte order in an array. -reverseRGBA_ptr :: Int -> Ptr Word8 -> IO () -reverseRGBA_ptr length8 ptr8 - = go (length8 `div` 4) (castPtr ptr8) 0 - where - go :: Int -> Ptr Word32 -> Int -> IO () - go len ptr count - | count < len - = do curr <- peekElemOff ptr count - let byte0 = shift (isolateByte0 curr) 24 - let byte1 = shift (isolateByte1 curr) 8 - let byte2 = shift (isolateByte2 curr) (-8) - let byte3 = shift (isolateByte3 curr) (-24) - pokeElemOff ptr count (byte0 .|. byte1 .|. byte2 .|. byte3) - go len ptr (count + 1) - - | otherwise - = return () - --- | Frees the allocated memory given to OpenGL to avoid a memory leak -freeBitmapData :: Ptr Word8 -> IO () -{-# INLINE freeBitmapData #-} -freeBitmapData p = free p - - --- | These functions work as bit masks to isolate the Word8 components -{-# INLINE isolateByte0 #-} -isolateByte0 :: Word32 -> Word32 -isolateByte0 word = - word .&. (255 :: Word32) - -{-# INLINE isolateByte1 #-} -isolateByte1 :: Word32 -> Word32 -isolateByte1 word = - word .&. (65280 :: Word32) - -{-# INLINE isolateByte2 #-} -isolateByte2 :: Word32 -> Word32 -isolateByte2 word = - word .&. (16711680 :: Word32) - -{-# INLINE isolateByte3 #-} -isolateByte3 :: Word32 -> Word32 -isolateByte3 word = - word .&. (4278190080 :: Word32) diff --git a/Graphics/Gloss/Internals/Render/Circle.hs b/Graphics/Gloss/Internals/Render/Circle.hs deleted file mode 100644 --- a/Graphics/Gloss/Internals/Render/Circle.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash, PatternGuards #-} -{-# OPTIONS_HADDOCK hide #-} - --- | Fast(ish) rendering of circles. -module Graphics.Gloss.Internals.Render.Circle - ( renderCircle - , renderArc) -where -import Graphics.Gloss.Internals.Render.Common -import Graphics.Gloss.Geometry.Angle -import qualified Graphics.Rendering.OpenGL.GL as GL -import GHC.Exts - - --- | Decide how many line segments to use to render the circle. --- The number of segments we should use to get a nice picture depends on --- the size of the circle on the screen, not its intrinsic radius. --- If the viewport has been zoomed-in then we need to use more segments. --- -{-# INLINE circleSteps #-} -circleSteps :: Float -> Int -circleSteps sDiam - | sDiam < 8 = 8 - | sDiam < 16 = 16 - | sDiam < 32 = 32 - | otherwise = 64 - - --- Circle --------------------------------------------------------------------- --- | Render a circle with the given thickness -renderCircle :: Float -> Float -> Float -> Float -> Float -> IO () -renderCircle posX posY scaleFactor radius_ thickness_ - = go (abs radius_) (abs thickness_) - where go radius thickness - - -- If the circle is smaller than a pixel, render it as a point. - | thickness == 0 - , radScreen <- scaleFactor * (radius + thickness / 2) - , radScreen <= 1 - = GL.renderPrimitive GL.Points - $ GL.vertex $ GL.Vertex2 (gf posX) (gf posY) - - -- Render zero thickness circles with lines. - | thickness == 0 - , radScreen <- scaleFactor * radius - , steps <- circleSteps radScreen - = renderCircleLine posX posY steps radius - - -- Some thick circle. - | radScreen <- scaleFactor * (radius + thickness / 2) - , steps <- circleSteps radScreen - = renderCircleStrip posX posY steps radius thickness - - --- | Render a circle as a line. -renderCircleLine :: Float -> Float -> Int -> Float -> IO () -renderCircleLine (F# posX) (F# posY) steps (F# rad) - = let n = fromIntegral steps - !(F# tStep) = (2 * pi) / n - !(F# tStop) = (2 * pi) - - in GL.renderPrimitive GL.LineLoop - $ renderCircleLine_step posX posY tStep tStop rad 0.0# -{-# INLINE renderCircleLine #-} - - --- | Render a circle with a given thickness as a triangle strip -renderCircleStrip :: Float -> Float -> Int -> Float -> Float -> IO () -renderCircleStrip (F# posX) (F# posY) steps r width - = let n = fromIntegral steps - !(F# tStep) = (2 * pi) / n - !(F# tStop) = (2 * pi) + (F# tStep) / 2 - !(F# r1) = r - width / 2 - !(F# r2) = r + width / 2 - - in GL.renderPrimitive GL.TriangleStrip - $ renderCircleStrip_step posX posY tStep tStop r1 0.0# r2 - (tStep `divideFloat#` 2.0#) -{-# INLINE renderCircleStrip #-} - - --- Arc ------------------------------------------------------------------------ --- | Render an arc with the given thickness. -renderArc :: Float -> Float -> Float -> Float -> Float -> Float -> Float -> IO () -renderArc posX posY scaleFactor radius_ a1 a2 thickness_ - = go (abs radius_) (abs thickness_) - where go radius thickness - - -- Render zero thickness arcs with lines. - | thickness == 0 - , radScreen <- scaleFactor * radius - , steps <- circleSteps radScreen - = renderArcLine posX posY steps radius a1 a2 - - -- Some thick arc. - | radScreen <- scaleFactor * (radius + thickness / 2) - , steps <- circleSteps radScreen - = renderArcStrip posX posY steps radius a1 a2 thickness - - --- | Render an arc as a line. -renderArcLine :: Float -> Float -> Int -> Float -> Float -> Float -> IO () -renderArcLine (F# posX) (F# posY) steps (F# rad) a1 a2 - = let n = fromIntegral steps - !(F# tStep) = (2 * pi) / n - !(F# tStart) = degToRad a1 - !(F# tStop) = degToRad a2 + if a1 >= a2 then 2 * pi else 0 - - -- force the line to end at the desired angle - endVertex = addPointOnCircle posX posY rad tStop - - in GL.renderPrimitive GL.LineStrip - $ do renderCircleLine_step posX posY tStep tStop rad tStart - endVertex -{-# INLINE renderArcLine #-} - - --- | Render an arc with a given thickness as a triangle strip -renderArcStrip :: Float -> Float -> Int -> Float -> Float -> Float -> Float -> IO () -renderArcStrip (F# posX) (F# posY) steps r a1 a2 width - = let n = fromIntegral steps - tStep = (2 * pi) / n - - t1 = normaliseAngle $ degToRad a1 - t2 = normaliseAngle $ degToRad a2 - (tStart, tStop) = if t1 <= t2 then (t1, t2) else (t2, t1) - tDiff = tStop - tStart - tMid = tStart + tDiff / 2 - - !(F# tStep') = tStep - !(F# tStep2') = tStep / 2 - !(F# tStart') = tStart - !(F# tStop') = tStop - !(F# tCut') = tStop - tStep - !(F# tMid') = tMid - !(F# r1') = r - width / 2 - !(F# r2') = r + width / 2 - - in GL.renderPrimitive GL.TriangleStrip - $ do - -- start vector - addPointOnCircle posX posY r1' tStart' - addPointOnCircle posX posY r2' tStart' - - -- If we don't have a complete step then just drop a point - -- between the two ending lines. - if tDiff < tStep - then do - addPointOnCircle posX posY r1' tMid' - - -- end vectors - addPointOnCircle posX posY r2' tStop' - addPointOnCircle posX posY r1' tStop' - - - else do - renderCircleStrip_step posX posY tStep' tCut' r1' tStart' r2' - (tStart' `plusFloat#` tStep2') - - -- end vectors - addPointOnCircle posX posY r1' tStop' - addPointOnCircle posX posY r2' tStop' -{-# INLINE renderArcStrip #-} - - --- Step functions ------------------------------------------------------------- -renderCircleLine_step - :: Float# -> Float# - -> Float# -> Float# - -> Float# -> Float# - -> IO () - -renderCircleLine_step posX posY tStep tStop rad tt - | 1# <- tt `geFloat#` tStop - = return () - - | otherwise - = do addPointOnCircle posX posY rad tt - renderCircleLine_step posX posY tStep tStop rad - (tt `plusFloat#` tStep) -{-# INLINE renderCircleLine_step #-} - - -renderCircleStrip_step - :: Float# -> Float# - -> Float# -> Float# - -> Float# -> Float# - -> Float# -> Float# -> IO () - -renderCircleStrip_step posX posY tStep tStop r1 t1 r2 t2 - | 1# <- t1 `geFloat#` tStop - = return () - - | otherwise - = do addPointOnCircle posX posY r1 t1 - addPointOnCircle posX posY r2 t2 - renderCircleStrip_step posX posY tStep tStop r1 - (t1 `plusFloat#` tStep) r2 (t2 `plusFloat#` tStep) -{-# INLINE renderCircleStrip_step #-} - - -addPoint :: Float# -> Float# -> IO () -addPoint x y = - GL.vertex $ GL.Vertex2 (gf (F# x)) (gf (F# y)) -{-# INLINE addPoint #-} - - -addPointOnCircle :: Float# -> Float# -> Float# -> Float# -> IO () -addPointOnCircle posX posY rad tt = - addPoint - (posX `plusFloat#` (rad `timesFloat#` (cosFloat# tt))) - (posY `plusFloat#` (rad `timesFloat#` (sinFloat# tt))) -{-# INLINE addPointOnCircle #-} - - - -{- Unused sector drawing code. - Sectors are currently drawn as compound Pictures, - but we might want this if we end up implementing the ThickSector - version as well. - --- | Render a sector as a line. -renderSectorLine :: Float -> Float -> Int -> Float -> Float -> Float -> IO () -renderSectorLine pX@(F# posX) pY@(F# posY) steps (F# rad) a1 a2 - = let n = fromIntegral steps - !(F# tStep) = (2 * pi) / n - !(F# tStart) = degToRad a1 - !(F# tStop) = degToRad a2 + if a1 >= a2 then 2 * pi else 0 - - -- need to set up the edges of the start/end triangles - startVertex = GL.vertex $ GL.Vertex2 (gf pX) (gf pY) - endVertex = addPointOnCircle posX posY rad tStop - - in GL.renderPrimitive GL.LineLoop - $ do startVertex - renderCircleLine_step posX posY tStep tStop rad tStart - endVertex - --- | Render a sector. -renderSector :: Float -> Float -> Float -> Float -> Float -> Float -> IO () -renderSector posX posY scaleFactor radius a1 a2 - | radScreen <- scaleFactor * radius - , steps <- circleSteps (2 * radScreen) - = renderSectorLine posX posY steps radius a1 a2 --} - diff --git a/Graphics/Gloss/Internals/Render/Common.hs b/Graphics/Gloss/Internals/Render/Common.hs deleted file mode 100644 --- a/Graphics/Gloss/Internals/Render/Common.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -module Graphics.Gloss.Internals.Render.Common where - -import Graphics.Gloss.Internals.Interface.Backend -import Graphics.Rendering.OpenGL (($=)) -import qualified Graphics.Rendering.OpenGL.GL as GL -import Unsafe.Coerce -import Data.IORef - --- | The OpenGL library doesn't seem to provide a nice way convert --- a Float to a GLfloat, even though they're the same thing --- under the covers. --- --- Using realToFrac is too slow, as it doesn't get fused in at --- least GHC 6.12.1 --- -gf :: Float -> GL.GLfloat -{-# INLINE gf #-} -gf x = unsafeCoerce x - --- | Used for similar reasons to above -gsizei :: Int -> GL.GLsizei -{-# INLINE gsizei #-} -gsizei x = unsafeCoerce x - --- | Perform a rendering action setting up the coords first -renderAction - :: Backend a - => IORef a - -> IO () - -> IO () - -renderAction backendRef action - = do - GL.matrixMode $= GL.Projection - GL.preservingMatrix - $ do - -- setup the co-ordinate system - GL.loadIdentity - (sizeX, sizeY) <- getWindowDimensions backendRef - let (sx, sy) = (fromIntegral sizeX / 2, fromIntegral sizeY / 2) - - GL.ortho (-sx) sx (-sy) sy 0 (-100) - - -- draw the world - GL.matrixMode $= GL.Modelview 0 - action - - GL.matrixMode $= GL.Projection - - GL.matrixMode $= GL.Modelview 0 diff --git a/Graphics/Gloss/Internals/Render/Picture.hs b/Graphics/Gloss/Internals/Render/Picture.hs deleted file mode 100644 --- a/Graphics/Gloss/Internals/Render/Picture.hs +++ /dev/null @@ -1,382 +0,0 @@ -{-# OPTIONS -fwarn-incomplete-patterns #-} -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE ImplicitParams, ScopedTypeVariables #-} - -module Graphics.Gloss.Internals.Render.Picture - (renderPicture) -where -import Graphics.Gloss.Data.Picture -import Graphics.Gloss.Data.Color -import Graphics.Gloss.Data.ViewPort -import Graphics.Gloss.Internals.Interface.Backend -import Graphics.Gloss.Internals.Render.State -import Graphics.Gloss.Internals.Render.Common -import Graphics.Gloss.Internals.Render.Circle -import Graphics.Gloss.Internals.Render.Bitmap -import System.Mem.StableName -import Foreign.ForeignPtr -import Data.IORef -import Data.List -import Control.Monad -import Graphics.Rendering.OpenGL (($=), get) -import qualified Graphics.Rendering.OpenGL.GL as GL -import qualified Graphics.Rendering.OpenGL.GLU.Errors as GLU -import qualified Graphics.UI.GLUT as GLUT - - --- | Render a picture using the given render options and viewport. -renderPicture - :: forall a . Backend a - => IORef a - -> State -- ^ The render state - -> ViewPort -- ^ The current viewport. - -> Picture -- ^ The picture to render. - -> IO () - -renderPicture - backendRef - renderS - viewS - picture - = do - -- This GL state doesn't change during rendering, - -- so we can just read it once here - (matProj_ :: GL.GLmatrix GL.GLdouble) - <- get $ GL.matrix (Just GL.Projection) - viewport_ <- get $ GL.viewport - windowSize_ <- getWindowDimensions backendRef - - -- - let ?modeWireframe = stateWireframe renderS - ?modeColor = stateColor renderS - ?refTextures = stateTextures renderS - ?matProj = matProj_ - ?viewport = viewport_ - ?windowSize = windowSize_ - - -- setup render state for world - setLineSmooth (stateLineSmooth renderS) - setBlendAlpha (stateBlendAlpha renderS) - - -- Adjust the picture - let picture' = applyViewPortToPicture viewS picture - checkErrors "before drawPicture." - drawPicture (viewPortScale viewS) picture' - checkErrors "after drawPicture." - - -drawPicture - :: ( ?modeWireframe :: Bool - , ?modeColor :: Bool - , ?refTextures :: IORef [Texture]) - => Float -> Picture -> IO () - -drawPicture circScale picture - = {-# SCC "drawComponent" #-} - case picture of - - -- nothin' - Blank - -> return () - - -- line - Line path - -> GL.renderPrimitive GL.LineStrip - $ vertexPFs path - - - -- polygon (where?) - Polygon path - | ?modeWireframe - -> GL.renderPrimitive GL.LineLoop - $ vertexPFs path - - | otherwise - -> GL.renderPrimitive GL.Polygon - $ vertexPFs path - - -- circle - Circle radius - -> renderCircle 0 0 circScale radius 0 - - ThickCircle radius thickness - -> renderCircle 0 0 circScale radius thickness - - -- arc - Arc a1 a2 radius - -> renderArc 0 0 circScale radius a1 a2 0 - - ThickArc a1 a2 radius thickness - -> renderArc 0 0 circScale radius a1 a2 thickness - - -- stroke text - -- text looks weird when we've got blend on, - -- so disable it during the renderString call. - Text str - -> do - GL.blend $= GL.Disabled - GL.preservingMatrix $ GLUT.renderString GLUT.Roman str - GL.blend $= GL.Enabled - - -- colors with float components. - Color col p - | ?modeColor - -> do oldColor <- get GL.currentColor - - let (r, g, b, a) = rgbaOfColor col - - GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a) - drawPicture circScale p - GL.currentColor $= oldColor - - | otherwise - -> drawPicture circScale p - - - -- Translation -------------------------- - -- Easy translations are done directly to avoid calling GL.perserveMatrix. - Translate posX posY (Circle radius) - -> renderCircle posX posY circScale radius 0 - - Translate posX posY (ThickCircle radius thickness) - -> renderCircle posX posY circScale radius thickness - - Translate posX posY (Arc a1 a2 radius) - -> renderArc posX posY circScale radius a1 a2 0 - - Translate posX posY (ThickArc a1 a2 radius thickness) - -> renderArc posX posY circScale radius a1 a2 thickness - - Translate tx ty (Rotate deg p) - -> GL.preservingMatrix - $ do GL.translate (GL.Vector3 (gf tx) (gf ty) 0) - GL.rotate (gf deg) (GL.Vector3 0 0 (-1)) - drawPicture circScale p - - Translate tx ty p - -> GL.preservingMatrix - $ do GL.translate (GL.Vector3 (gf tx) (gf ty) 0) - drawPicture circScale p - - - -- Rotation ----------------------------- - -- Easy rotations are done directly to avoid calling GL.perserveMatrix. - Rotate _ (Circle radius) - -> renderCircle 0 0 circScale radius 0 - - Rotate _ (ThickCircle radius thickness) - -> renderCircle 0 0 circScale radius thickness - - Rotate deg (Arc a1 a2 radius) - -> renderArc 0 0 circScale radius (a1-deg) (a2-deg) 0 - - Rotate deg (ThickArc a1 a2 radius thickness) - -> renderArc 0 0 circScale radius (a1-deg) (a2-deg) thickness - - - Rotate deg p - -> GL.preservingMatrix - $ do GL.rotate (gf deg) (GL.Vector3 0 0 (-1)) - drawPicture circScale p - - - -- Scale -------------------------------- - Scale sx sy p - -> GL.preservingMatrix - $ do GL.scale (gf sx) (gf sy) 1 - let mscale = max sx sy - drawPicture (circScale * mscale) p - - -- Bitmap ------------------------------- - Bitmap width height imgData cacheMe - -> do - -- Load the image data into a texture, - -- or grab it from the cache if we've already done that before. - tex <- loadTexture ?refTextures width height imgData cacheMe - - -- Set up wrap and filtering mode - GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat) - GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat) - GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest) - - -- Enable texturing - GL.texture GL.Texture2D $= GL.Enabled - GL.textureFunction $= GL.Combine - - -- Set current texture - GL.textureBinding GL.Texture2D $= Just (texObject tex) - - -- Set to opaque - GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0 - - -- Draw textured polygon - GL.renderPrimitive GL.Polygon - $ zipWithM_ - (\(pX, pY) (tX, tY) - -> do GL.texCoord $ GL.TexCoord2 (gf tX) (gf tY) - GL.vertex $ GL.Vertex2 (gf pX) (gf pY)) - - (bitmapPath (fromIntegral width) (fromIntegral height)) - [(0,0), (1.0,0), (1.0,1.0), (0,1.0)] - - -- Disable texturing - GL.texture GL.Texture2D $= GL.Disabled - - -- Free uncachable texture objects. - freeTexture tex - - - Pictures ps - -> mapM_ (drawPicture circScale) ps - --- Errors --------------------------------------------------------------------- -checkErrors :: String -> IO () -checkErrors place - = do errors <- get $ GLU.errors - when (not $ null errors) - $ mapM_ (handleError place) errors - -handleError :: String -> GLU.Error -> IO () -handleError place err - = case err of - GLU.Error GLU.StackOverflow _ - -> error $ unlines - [ "Gloss / OpenGL Stack Overflow " ++ show place - , " This program uses the Gloss vector graphics library, which tried to" - , " draw a picture using more nested transforms (Translate/Rotate/Scale)" - , " than your OpenGL implementation supports. The OpenGL spec requires" - , " all implementations to have a transform stack depth of at least 32," - , " and Gloss tries not to push the stack when it doesn't have to, but" - , " that still wasn't enough." - , "" - , " You should complain to your harware vendor that they don't provide" - , " a better way to handle this situation at the OpenGL API level." - , "" - , " To make this program work you'll need to reduce the number of nested" - , " transforms used when defining the Picture given to Gloss. Sorry." ] - - -- Issue #32: Spurious "Invalid Operation" errors under Windows 7 64-bit. - -- When using GLUT under Windows 7 it complains about InvalidOperation, - -- but doesn't provide any other details. All the examples look ok, so - -- we're just ignoring the error for now. - GLU.Error GLU.InvalidOperation _ - -> return () - _ - -> error $ unlines - [ "Gloss / OpenGL Internal Error " ++ show place - , " Please report this on haskell-gloss@googlegroups.com." - , show err ] - - --- Textures ------------------------------------------------------------------- --- | Load a texture. --- If we've seen it before then use the pre-installed one from the texture --- cache, otherwise load it into OpenGL. -loadTexture - :: IORef [Texture] - -> Int -> Int -> BitmapData - -> Bool - -> IO Texture - -loadTexture refTextures width height imgData cacheMe - = do textures <- readIORef refTextures - - -- Try and find this same texture in the cache. - name <- makeStableName imgData - let mTexCached - = find (\tex -> texName tex == name - && texWidth tex == width - && texHeight tex == height) - textures - - case mTexCached of - Just tex - -> return tex - - Nothing - -> do tex <- installTexture width height imgData cacheMe - when cacheMe - $ writeIORef refTextures (tex : textures) - return tex - - --- | Install a texture into OpenGL. -installTexture - :: Int -> Int - -> BitmapData - -> Bool - -> IO Texture - -installTexture width height bitmapData@(BitmapData _ fptr) cacheMe - = do - -- Allocate texture handle for texture - [tex] <- GL.genObjectNames 1 - GL.textureBinding GL.Texture2D $= Just tex - - -- Sets the texture in imgData as the current texture - -- This copies the data from the pointer into OpenGL texture memory, - -- so it's ok if the foreignptr gets garbage collected after this. - withForeignPtr fptr - $ \ptr -> - GL.texImage2D - GL.Texture2D - GL.NoProxy - 0 - GL.RGBA8 - (GL.TextureSize2D - (gsizei width) - (gsizei height)) - 0 - (GL.PixelData GL.RGBA GL.UnsignedInt8888 ptr) - - -- Make a stable name that we can use to identify this data again. - -- If the user gives us the same texture data at the same size then we - -- can avoid loading it into texture memory again. - name <- makeStableName bitmapData - - return Texture - { texName = name - , texWidth = width - , texHeight = height - , texData = fptr - , texObject = tex - , texCacheMe = cacheMe } - - --- | If this texture does not have its `cacheMe` flag set then delete it from --- OpenGL and free the memory. -freeTexture :: Texture -> IO () -freeTexture tex - | texCacheMe tex = return () - | otherwise = GL.deleteObjectNames [texObject tex] - - - --- Utils ---------------------------------------------------------------------- --- | Turn alpha blending on or off -setBlendAlpha :: Bool -> IO () -setBlendAlpha state - | state - = do GL.blend $= GL.Enabled - GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) - - | otherwise - = do GL.blend $= GL.Disabled - GL.blendFunc $= (GL.One, GL.Zero) - --- | Turn line smoothing on or off -setLineSmooth :: Bool -> IO () -setLineSmooth state - | state = GL.lineSmooth $= GL.Enabled - | otherwise = GL.lineSmooth $= GL.Disabled - - -vertexPFs :: [(Float, Float)] -> IO () -{-# INLINE vertexPFs #-} -vertexPFs [] = return () -vertexPFs ((x, y) : rest) - = do GL.vertex $ GL.Vertex2 (gf x) (gf y) - vertexPFs rest - - - diff --git a/Graphics/Gloss/Internals/Render/State.hs b/Graphics/Gloss/Internals/Render/State.hs deleted file mode 100644 --- a/Graphics/Gloss/Internals/Render/State.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - --- | Rendering options -module Graphics.Gloss.Internals.Render.State - ( State (..) - , stateInit - , Texture (..)) -where -import qualified Graphics.Rendering.OpenGL.GL as GL -import Foreign.ForeignPtr -import System.Mem.StableName -import Data.Word -import Data.IORef -import Graphics.Gloss.Data.Picture - --- | Render options settings -data State - = State - { -- | Whether to use color - stateColor :: !Bool - - -- | Whether to force wireframe mode only - , stateWireframe :: !Bool - - -- | Whether to use alpha blending - , stateBlendAlpha :: !Bool - - -- | Whether to use line smoothing - , stateLineSmooth :: !Bool - - -- | Cache of Textures that we've sent to OpenGL. - , stateTextures :: !(IORef [Texture]) - } - - --- | A texture that we've sent to OpenGL. -data Texture - = Texture - { -- | Stable name derived from the `BitmapData` that the user gives us. - texName :: StableName BitmapData - - -- | Width of the image, in pixels. - , texWidth :: Int - - -- | Height of the image, in pixels. - , texHeight :: Int - - -- | Pointer to the Raw texture data. - , texData :: ForeignPtr Word8 - - -- | The OpenGL texture object. - , texObject :: GL.TextureObject - - -- | Whether we want to leave this in OpenGL texture memory between frames. - , texCacheMe :: Bool } - - --- | Default render options -stateInit :: IO State -stateInit - = do textures <- newIORef [] - return State - { stateColor = True - , stateWireframe = False - , stateBlendAlpha = True - , stateLineSmooth = False - , stateTextures = textures } - - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2010-2014 Benjamin Lippmeier +Copyright (c) 2010-2016 The Gloss Development Team Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation diff --git a/gloss.cabal b/gloss.cabal --- a/gloss.cabal +++ b/gloss.cabal @@ -1,76 +1,82 @@ Name: gloss -Version: 1.8.2.2 +Version: 1.13.2.2 License: MIT License-file: LICENSE Author: Ben Lippmeier Maintainer: benl@ouroborus.net Build-Type: Simple -Cabal-Version: >=1.6 +Cabal-Version: >=1.10 Stability: stable Category: Graphics Homepage: http://gloss.ouroborus.net Bug-reports: gloss@ouroborus.net Description: - Gloss hides the pain of drawing simple vector graphics behind a nice data type and - a few display functions. Gloss uses OpenGL under the hood, but you won't need to - worry about any of that. Get something cool on the screen in under 10 minutes. + Gloss hides the pain of drawing simple vector graphics behind a nice data type and + a few display functions. Gloss uses OpenGL under the hood, but you won't need to + worry about any of that. Get something cool on the screen in under 10 minutes. Synopsis: Painless 2D vector graphics, animations and simulations. source-repository head - type: git - location: https://github.com/benl23x5/gloss + type: git + location: https://github.com/benl23x5/gloss +source-repository this + type: git + tag: v1.13.0.0 + location: https://github.com/benl23x5/gloss + Flag GLUT - Description: Enable the GLUT backend - Default: True + Description: Enable the GLUT backend + Default: True Flag GLFW - Description: Enable the GLFW backend - Default: False - -Flag ExplicitBackend - Description: Expose versions of 'display' and friends that allow - you to choose what window manager backend to use. - Default: False + Description: Enable the GLFW backend + Default: False Library - Build-Depends: - base == 4.7.*, - ghc-prim == 0.3.*, - containers == 0.5.*, - bytestring == 0.10.*, - OpenGL == 2.9.*, - GLUT == 2.5.*, - bmp == 1.2.* + Build-Depends: + base >= 4.8 && < 5 + , ghc-prim + , bmp == 1.2.* + , bytestring == 0.11.* + , containers >= 0.5 && < 0.7 + , gloss-rendering == 1.13.* + , GLUT == 2.7.* + , OpenGL >= 2.12 && < 3.1 ghc-options: - -O2 -Wall + -O2 + -Wall + Default-Language: + Haskell2010 + Exposed-modules: Graphics.Gloss - Graphics.Gloss.Geometry - Graphics.Gloss.Geometry.Angle - Graphics.Gloss.Geometry.Line + Graphics.Gloss.Data.Bitmap + Graphics.Gloss.Data.Color + Graphics.Gloss.Data.Controller Graphics.Gloss.Data.Display + Graphics.Gloss.Data.Picture Graphics.Gloss.Data.Point + Graphics.Gloss.Data.Point.Arithmetic Graphics.Gloss.Data.Vector - Graphics.Gloss.Data.Quad - Graphics.Gloss.Data.Extent - Graphics.Gloss.Data.QuadTree - Graphics.Gloss.Data.Color - Graphics.Gloss.Data.Picture Graphics.Gloss.Data.ViewPort Graphics.Gloss.Data.ViewState - Graphics.Gloss.Algorithms.RayCast + Graphics.Gloss.Geometry.Angle + Graphics.Gloss.Geometry.Line Graphics.Gloss.Interface.Pure.Display Graphics.Gloss.Interface.Pure.Animate Graphics.Gloss.Interface.Pure.Simulate Graphics.Gloss.Interface.Pure.Game Graphics.Gloss.Interface.IO.Animate + Graphics.Gloss.Interface.IO.Display + Graphics.Gloss.Interface.IO.Interact Graphics.Gloss.Interface.IO.Simulate Graphics.Gloss.Interface.IO.Game + Graphics.Gloss.Interface.Environment Other-modules: Graphics.Gloss.Internals.Color @@ -87,31 +93,25 @@ Graphics.Gloss.Internals.Interface.ViewState.Motion Graphics.Gloss.Internals.Interface.ViewState.Reshape Graphics.Gloss.Internals.Interface.Window - Graphics.Gloss.Internals.Render.Bitmap - Graphics.Gloss.Internals.Render.Circle - Graphics.Gloss.Internals.Render.Common - Graphics.Gloss.Internals.Render.State - Graphics.Gloss.Internals.Render.Picture - Graphics.Gloss.Internals.Interface.Display Graphics.Gloss.Internals.Interface.Animate + Graphics.Gloss.Internals.Interface.Interact Graphics.Gloss.Internals.Interface.Simulate Graphics.Gloss.Internals.Interface.Game Graphics.Gloss.Internals.Interface.Backend - Extensions: - DeriveDataTypeable - PatternGuards - If flag(GLUT) CPP-Options: -DWITHGLUT Other-modules: - Graphics.Gloss.Internals.Interface.Backend.GLUT + Graphics.Gloss.Internals.Interface.Backend.GLUT + -- NOTE: GLUT is still required for text rendering, and must be initialized + -- on Linux platforms. Thus, the GLFW backend still requires GLUT. If flag(GLFW) Build-Depends: - GLFW-b >= 0.1.4.1 && < 0.2 + GLFW-b >= 1.4.1.0 && < 2 CPP-Options: -DWITHGLFW Other-modules: Graphics.Gloss.Internals.Interface.Backend.GLFW +-- vim: nospell