gloss 1.8.2.2 → 1.13.2.2
raw patch · 56 files changed
Files
- Graphics/Gloss.hs +61/−33
- Graphics/Gloss/Algorithms/RayCast.hs +0/−82
- Graphics/Gloss/Data/Bitmap.hs +16/−0
- Graphics/Gloss/Data/Color.hs +131/−188
- Graphics/Gloss/Data/Controller.hs +15/−0
- Graphics/Gloss/Data/Display.hs +2/−2
- Graphics/Gloss/Data/Extent.hs +0/−195
- Graphics/Gloss/Data/Picture.hs +50/−213
- Graphics/Gloss/Data/Point.hs +12/−34
- Graphics/Gloss/Data/Point/Arithmetic.hs +55/−0
- Graphics/Gloss/Data/Quad.hs +0/−17
- Graphics/Gloss/Data/QuadTree.hs +0/−191
- Graphics/Gloss/Data/Vector.hs +29/−32
- Graphics/Gloss/Data/ViewPort.hs +51/−32
- Graphics/Gloss/Data/ViewState.hs +110/−52
- Graphics/Gloss/Geometry.hs +0/−8
- Graphics/Gloss/Geometry/Angle.hs +11/−11
- Graphics/Gloss/Geometry/Line.hs +174/−175
- Graphics/Gloss/Interface/Environment.hs +18/−0
- Graphics/Gloss/Interface/IO/Animate.hs +21/−11
- Graphics/Gloss/Interface/IO/Display.hs +67/−0
- Graphics/Gloss/Interface/IO/Game.hs +3/−2
- Graphics/Gloss/Interface/IO/Interact.hs +41/−0
- Graphics/Gloss/Interface/IO/Simulate.hs +4/−4
- Graphics/Gloss/Interface/Pure/Animate.hs +8/−7
- Graphics/Gloss/Interface/Pure/Display.hs +10/−15
- Graphics/Gloss/Interface/Pure/Game.hs +24/−22
- Graphics/Gloss/Interface/Pure/Simulate.hs +25/−22
- Graphics/Gloss/Internals/Color.hs +8/−8
- Graphics/Gloss/Internals/Interface/Animate.hs +69/−43
- Graphics/Gloss/Internals/Interface/Animate/State.hs +33/−33
- Graphics/Gloss/Internals/Interface/Animate/Timing.hs +46/−42
- Graphics/Gloss/Internals/Interface/Backend.hs +1/−1
- Graphics/Gloss/Internals/Interface/Backend/GLFW.hs +339/−210
- Graphics/Gloss/Internals/Interface/Backend/GLUT.hs +139/−46
- Graphics/Gloss/Internals/Interface/Backend/Types.hs +27/−8
- Graphics/Gloss/Internals/Interface/Common/Exit.hs +14/−13
- Graphics/Gloss/Internals/Interface/Debug.hs +52/−52
- Graphics/Gloss/Internals/Interface/Display.hs +66/−35
- Graphics/Gloss/Internals/Interface/Event.hs +32/−33
- Graphics/Gloss/Internals/Interface/Game.hs +102/−90
- Graphics/Gloss/Internals/Interface/Interact.hs +160/−0
- Graphics/Gloss/Internals/Interface/Simulate.hs +74/−65
- Graphics/Gloss/Internals/Interface/Simulate/Idle.hs +66/−116
- Graphics/Gloss/Internals/Interface/Simulate/State.hs +16/−32
- Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs +12/−12
- Graphics/Gloss/Internals/Interface/ViewState/Motion.hs +14/−13
- Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs +11/−11
- Graphics/Gloss/Internals/Interface/Window.hs +54/−50
- Graphics/Gloss/Internals/Render/Bitmap.hs +0/−86
- Graphics/Gloss/Internals/Render/Circle.hs +0/−246
- Graphics/Gloss/Internals/Render/Common.hs +0/−51
- Graphics/Gloss/Internals/Render/Picture.hs +0/−382
- Graphics/Gloss/Internals/Render/State.hs +0/−69
- LICENSE +1/−1
- gloss.cabal +46/−46
Graphics/Gloss.hs view
@@ -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 <http://gloss.ouroborus.net>. ---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+
− Graphics/Gloss/Algorithms/RayCast.hs
@@ -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 ]- - _ -> []
+ Graphics/Gloss/Data/Bitmap.hs view
@@ -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+
Graphics/Gloss/Data/Color.hs view
@@ -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+
+ Graphics/Gloss/Data/Controller.hs view
@@ -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 () }
Graphics/Gloss/Data/Display.hs view
@@ -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)
− Graphics/Gloss/Data/Extent.hs
@@ -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)-
Graphics/Gloss/Data/Picture.hs view
@@ -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
Graphics/Gloss/Data/Point.hs view
@@ -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
+ Graphics/Gloss/Data/Point/Arithmetic.hs view
@@ -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')
− Graphics/Gloss/Data/Quad.hs
@@ -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]
− Graphics/Gloss/Data/QuadTree.hs
@@ -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'--
Graphics/Gloss/Data/Vector.hs view
@@ -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 #-}
Graphics/Gloss/Data/ViewPort.hs view
@@ -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 #-}
Graphics/Gloss/Data/ViewState.hs view
@@ -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+
− Graphics/Gloss/Geometry.hs
@@ -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-
Graphics/Gloss/Geometry/Angle.hs view
@@ -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 #-}
Graphics/Gloss/Geometry/Line.hs view
@@ -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
+ Graphics/Gloss/Interface/Environment.hs view
@@ -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+
Graphics/Gloss/Interface/IO/Animate.hs view
@@ -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+
+ Graphics/Gloss/Interface/IO/Display.hs view
@@ -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++
Graphics/Gloss/Interface/IO/Game.hs view
@@ -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
+ Graphics/Gloss/Interface/IO/Interact.hs view
@@ -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
Graphics/Gloss/Interface/IO/Simulate.hs view
@@ -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 ()
Graphics/Gloss/Interface/Pure/Animate.hs view
@@ -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 ()))
Graphics/Gloss/Interface/Pure/Display.hs view
@@ -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 ()))
Graphics/Gloss/Interface/Pure/Game.hs view
@@ -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 ()
Graphics/Gloss/Interface/Pure/Simulate.hs view
@@ -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 () - +
Graphics/Gloss/Internals/Color.hs view
@@ -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
Graphics/Gloss/Internals/Interface/Animate.hs view
@@ -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
Graphics/Gloss/Internals/Interface/Animate/State.hs view
@@ -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 }
Graphics/Gloss/Internals/Interface/Animate/Timing.hs view
@@ -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+
Graphics/Gloss/Internals/Interface/Backend.hs view
@@ -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
Graphics/Gloss/Internals/Interface/Backend/GLFW.hs view
@@ -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
Graphics/Gloss/Internals/Interface/Backend/GLUT.hs view
@@ -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)
Graphics/Gloss/Internals/Interface/Backend/Types.hs view
@@ -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)+
Graphics/Gloss/Internals/Interface/Common/Exit.hs view
@@ -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 ()
Graphics/Gloss/Internals/Interface/Debug.hs view
@@ -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"
Graphics/Gloss/Internals/Interface/Display.hs view
@@ -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+ }++
Graphics/Gloss/Internals/Interface/Event.hs view
@@ -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'
Graphics/Gloss/Internals/Interface/Game.hs view
@@ -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
+ Graphics/Gloss/Internals/Interface/Interact.hs view
@@ -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+
Graphics/Gloss/Internals/Interface/Simulate.hs view
@@ -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 ()))++
Graphics/Gloss/Internals/Interface/Simulate/Idle.hs view
@@ -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- +
Graphics/Gloss/Internals/Interface/Simulate/State.hs view
@@ -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 }++
Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs view
@@ -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
Graphics/Gloss/Internals/Interface/ViewState/Motion.hs view
@@ -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
Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs view
@@ -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
Graphics/Gloss/Internals/Interface/Window.hs view
@@ -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"+
− Graphics/Gloss/Internals/Render/Bitmap.hs
@@ -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)
− Graphics/Gloss/Internals/Render/Circle.hs
@@ -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--}-
− Graphics/Gloss/Internals/Render/Common.hs
@@ -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
− Graphics/Gloss/Internals/Render/Picture.hs
@@ -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---
− Graphics/Gloss/Internals/Render/State.hs
@@ -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 }- -
LICENSE view
@@ -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
gloss.cabal view
@@ -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