diff --git a/Graphics/Gloss.hs b/Graphics/Gloss.hs --- a/Graphics/Gloss.hs +++ b/Graphics/Gloss.hs @@ -25,11 +25,23 @@ -- `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 +-- will limit the frame-rate to around 20Hz. +-- +-- -- @Release Notes: -- +-- 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.6.0: -- Thanks to Anthony Cowley -- * Full screen display mode. @@ -61,7 +73,7 @@ import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.Color -import Graphics.Gloss.Internals.Interface.Display -import Graphics.Gloss.Internals.Interface.Animate -import Graphics.Gloss.Internals.Interface.Simulate -import Graphics.Gloss.Internals.Interface.Game +import Graphics.Gloss.Interface.Pure.Display +import Graphics.Gloss.Interface.Pure.Animate +import Graphics.Gloss.Interface.Pure.Simulate +import Graphics.Gloss.Interface.Pure.Game diff --git a/Graphics/Gloss/Algorithms/RayCast.hs b/Graphics/Gloss/Algorithms/RayCast.hs --- a/Graphics/Gloss/Algorithms/RayCast.hs +++ b/Graphics/Gloss/Algorithms/RayCast.hs @@ -74,9 +74,9 @@ 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 ] + [ traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent NW extent) nw + , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent NE extent) ne + , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent SW extent) sw + , traceSegIntoCellularQuadTree p1 p2 (cutQuadOfExtent SE extent) se ] _ -> [] diff --git a/Graphics/Gloss/Data/Extent.hs b/Graphics/Gloss/Data/Extent.hs --- a/Graphics/Gloss/Data/Extent.hs +++ b/Graphics/Gloss/Data/Extent.hs @@ -1,7 +1,8 @@ {-# 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. +-- 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 @@ -26,7 +27,8 @@ -- | A rectangular area of the 2D plane. --- We keep the type abstract to ensure that invalid extents cannot be constructed. +-- We keep the type abstract to ensure that invalid extents cannot be +-- constructed. data Extent = Extent Int Int Int Int deriving (Eq, Show) @@ -136,8 +138,9 @@ 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`. +-- | 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 @@ -182,7 +185,8 @@ w = fromIntegral w' --- | Check whether a line segment's endpoints are inside an extent, or if it intersects with the boundary. +-- | 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 diff --git a/Graphics/Gloss/Data/Picture.hs b/Graphics/Gloss/Data/Picture.hs --- a/Graphics/Gloss/Data/Picture.hs +++ b/Graphics/Gloss/Data/Picture.hs @@ -8,27 +8,40 @@ , BitmapData -- * Aliases for Picture constructors - , blank, polygon, line, circle, thickCircle, text, bitmap - , color, translate, rotate, scale + , blank + , polygon + , line + , circle, thickCircle + , arc, thickArc + , text + , bitmap + , color + , translate, rotate, scale , pictures + -- * Compound shapes + , lineLoop + , circleSolid + , arcSolid + , sectorWire + , rectanglePath + , rectangleWire + , rectangleSolid + , rectangleUpperPath + , rectangleUpperWire + , rectangleUpperSolid + -- * Loading Bitmaps , bitmapOfForeignPtr - , bitmapOfByteString - , bitmapOfBMP - , loadBMP + , bitmapOfByteString + , bitmapOfBMP + , loadBMP) - -- * Miscellaneous - , lineLoop - , circleSolid - - -- * Rectangles - , rectanglePath, rectangleWire, rectangleSolid - , rectangleUpperPath, rectangleUpperWire, rectangleUpperSolid) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Point import Graphics.Gloss.Data.Vector +import Graphics.Gloss.Geometry.Angle import Graphics.Gloss.Internals.Render.Bitmap import Codec.BMP import Foreign.ForeignPtr @@ -40,7 +53,7 @@ import Data.ByteString 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] @@ -64,16 +77,27 @@ -- | A circle with the given thickness and radius. -- If the thickness is 0 then this is equivalent to `Circle`. - | ThickCircle Float Float + | 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 a Vector holding the 32 bit RGBA bitmap data. + -- | 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`. + -- 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 ------------------------------------------ @@ -84,7 +108,7 @@ -- | A picture translated by the given x and y coordinates. | Translate Float Float Picture - -- | A picture rotated by the given angle (in degrees). + -- | A picture rotated clockwise by the given angle (in degrees). | Rotate Float Picture -- | A picture scaled by the given x and y factors. @@ -96,53 +120,92 @@ deriving (Show, Eq) --- Instances ------------------------------------------------------------------------------------- +-- Instances ------------------------------------------------------------------ instance Monoid Picture where mempty = blank mappend a b = Pictures [a, b] mconcat = Pictures --- Constructors ---------------------------------------------------------------------------------- +-- 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 +-- | A convex polygon filled with a solid color. polygon :: Path -> Picture polygon = Polygon +-- | A line along an arbitrary path. line :: Path -> Picture line = Line -circle :: Float -> Picture +-- | A circle with the given radius. +circle :: Float -> Picture circle = Circle -thickCircle :: Float -> Float -> Picture +-- | 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) +-- at the given radius. +arc :: Float -> Float -> Float -> Picture +arc = Arc + +-- | 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 -> Picture +thickArc = ThickArc + +-- | Some text to draw with a vector font. text :: String -> Picture text = Text -bitmap :: Int -> Int -> BitmapData -> Bool -> Picture +-- | 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 picture drawn with this color. color :: Color -> Picture -> Picture color = Color +-- | A picture translated by the given x and y coordinates. translate :: Float -> Float -> Picture -> Picture translate = Translate -rotate :: Float -> Picture -> Picture +-- | A picture rotated clockwise by the given angle (in degrees). +rotate :: Float -> Picture -> Picture rotate = Rotate -scale :: Float -> Float -> Picture -> Picture +-- | A picture scaled by the given x and y factors. +scale :: Float -> Float -> Picture -> Picture scale = Scale +-- | A picture consisting of several others. pictures :: [Picture] -> Picture pictures = Pictures -- Bitmaps -------------------------------------------------------------------- --- | O(1). Use a `ForeignPtr` of RGBA data as a bitmap. +-- | 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 @@ -150,7 +213,13 @@ in Bitmap width height bdata cacheMe --- | O(size). Copy a `ByteString` of RGBA data into a bitmap. +-- | 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 @@ -196,58 +265,86 @@ Right bmp -> return $ bitmapOfBMP bmp --- Shapes ---------------------------------------------------------------------------------------- --- | A closed loop along this path. +-- Other Shapes --------------------------------------------------------------- +-- | A closed loop along a path. lineLoop :: Path -> Picture lineLoop [] = Line [] lineLoop (x:xs) = Line ((x:xs) ++ [x]) --- | A path representing a rectangle centered about the origin, --- with the given width and height. -rectanglePath :: Float -> Float -> Path +-- Circles and Arcs ----------------------------------------------------------- +-- | A solid circle with the given radius. +circleSolid :: Float -> Picture +circleSolid r + = thickCircle (r/2) r + + +-- | A solid arc, drawn counter-clockwise between two angles at the given radius. +arcSolid :: Float -> Float -> Float -> Picture +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 +-- 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 +-- 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 + [ 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))] ] + + +-- Rectangles ----------------------------------------------------------------- +-- NOTE: Only the first of these rectangle functions has haddocks on the +-- arguments to reduce the amount of noise in the extracted docs. + +-- | A path representing a rectangle centered about the origin +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)] --- | A wireframe rectangle centered about the origin, --- with the given width and height. +-- | A wireframe rectangle centered about the origin. rectangleWire :: Float -> Float -> Picture rectangleWire sizeX sizeY = lineLoop $ rectanglePath sizeX sizeY --- | A wireframe rectangle in the y > 0 half of the x-y plane, --- with the given width and height. +-- | A wireframe rectangle in the y > 0 half of the x-y plane. rectangleUpperWire :: Float -> Float -> Picture rectangleUpperWire sizeX sizeY = lineLoop $ rectangleUpperPath sizeX sizeY --- | A path representing a rectangle in the y > 0 half of the x-y plane, --- with the given width and height +-- | 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)] --- | A solid rectangle centered about the origin, --- with the given width and height. +-- | A solid rectangle centered about the origin. rectangleSolid :: Float -> Float -> Picture rectangleSolid sizeX sizeY = Polygon $ rectanglePath sizeX sizeY --- | A solid rectangle in the y > 0 half of the x-y plane, --- with the given width and height. +-- | A solid rectangle in the y > 0 half of the x-y plane. rectangleUpperSolid :: Float -> Float -> Picture rectangleUpperSolid sizeX sizeY = Polygon $ rectangleUpperPath sizeX sizeY - --- | A solid circle with the given radius. -circleSolid :: Float -> Picture -circleSolid r = thickCircle (r/2) r diff --git a/Graphics/Gloss/Data/Point.hs b/Graphics/Gloss/Data/Point.hs --- a/Graphics/Gloss/Data/Point.hs +++ b/Graphics/Gloss/Data/Point.hs @@ -6,7 +6,8 @@ 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. +-- Points can also be treated as `Vector`s, so "Graphics.Gloss.Data.Vector" +-- may also be useful. type Point = (Float, Float) diff --git a/Graphics/Gloss/Geometry/Line.hs b/Graphics/Gloss/Geometry/Line.hs --- a/Graphics/Gloss/Geometry/Line.hs +++ b/Graphics/Gloss/Geometry/Line.hs @@ -2,7 +2,8 @@ -- | 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. +-- A @Line@ is taken to be infinite in length, while a @Seg@ is finite length +-- line segment represented by its two endpoints. module Graphics.Gloss.Geometry.Line ( segClearsBox @@ -94,11 +95,11 @@ --- Line-Line intersection ------------------------------------------------------------------------- +-- Line-Line intersection ----------------------------------------------------- --- | Given four points specifying two lines, get the point where the two lines cross, if any. --- Note that the lines extend off to infinity, so the intersection point might not lie --- between either of the two pairs of points. +-- | Given four points specifying two lines, get the point where the two lines +-- cross, if any. Note that the lines extend off to infinity, so the +-- intersection point might not line between either of the two pairs of points. -- -- @ -- \\ / @@ -137,9 +138,9 @@ in Just (numx / den, numy / den) --- Segment-Line intersection ---------------------------------------------------------------------- - --- | Get the point where a segment @P1-P2@ crosses an infinite line @P3-P4@, if any. +-- Segment-Line intersection -------------------------------------------------- +-- | Get the point where a segment @P1-P2@ crosses an infinite line @P3-P4@, +-- if any. -- intersectSegLine :: Point -- ^ `P1` @@ -237,9 +238,10 @@ , (x0 - x1) * (y2 - y1) / (x2 - x1) + y1) --- Segment-Segment intersection ------------------------------------------------------------------- +-- Segment-Segment intersection ----------------------------------------------- --- | Get the point where a segment @P1-P2@ crosses another segement @P3-P4@, if any. +-- | Get the point where a segment @P1-P2@ crosses another segement @P3-P4@, +-- if any. intersectSegSeg :: Point -- ^ `P1` -> Point -- ^ `P2` @@ -286,8 +288,8 @@ | x0 > xb = Nothing | otherwise = Just (x0, y0) - where x0 | (y2 - y1) == 0 = x1 - | otherwise = (y0 - y1) * (x2 - x1) / (y2 - y1) + x1 + where x0 | (y2 - y1) == 0 = x1 + | otherwise = (y0 - y1) * (x2 - x1) / (y2 - y1) + x1 -- | Check if an arbitrary segment intersects a vertical segment. @@ -318,7 +320,7 @@ | y0 > yb = Nothing | otherwise = Just (x0, y0) - where y0 | (x2 - x1) == 0 = y1 - | otherwise = (x0 - x1) * (y2 - y1) / (x2 - x1) + y1 + where y0 | (x2 - x1) == 0 = y1 + | otherwise = (x0 - x1) * (y2 - y1) / (x2 - x1) + y1 diff --git a/Graphics/Gloss/Interface/Animate.hs b/Graphics/Gloss/Interface/Animate.hs deleted file mode 100644 --- a/Graphics/Gloss/Interface/Animate.hs +++ /dev/null @@ -1,12 +0,0 @@ - --- | Display mode is for drawing a static picture. -module Graphics.Gloss.Interface.Animate - ( module Graphics.Gloss.Data.Display - , module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color - , animate) -where -import Graphics.Gloss.Data.Display -import Graphics.Gloss.Data.Picture -import Graphics.Gloss.Data.Color -import Graphics.Gloss.Internals.Interface.Animate diff --git a/Graphics/Gloss/Interface/Display.hs b/Graphics/Gloss/Interface/Display.hs deleted file mode 100644 --- a/Graphics/Gloss/Interface/Display.hs +++ /dev/null @@ -1,12 +0,0 @@ - --- | Display mode is for drawing a static picture. -module Graphics.Gloss.Interface.Display - ( module Graphics.Gloss.Data.Display - , module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color - , display) -where -import Graphics.Gloss.Data.Display -import Graphics.Gloss.Data.Picture -import Graphics.Gloss.Data.Color -import Graphics.Gloss.Internals.Interface.Display diff --git a/Graphics/Gloss/Interface/Game.hs b/Graphics/Gloss/Interface/Game.hs deleted file mode 100644 --- a/Graphics/Gloss/Interface/Game.hs +++ /dev/null @@ -1,18 +0,0 @@ - --- 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.Game - ( module Graphics.Gloss.Data.Display - , module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color - , play - , Event(..), Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..)) -where -import Graphics.Gloss.Data.Display -import Graphics.Gloss.Data.Picture -import Graphics.Gloss.Data.Color -import Graphics.Gloss.Internals.Interface.Game -import Graphics.Gloss.Internals.Interface.Backend diff --git a/Graphics/Gloss/Interface/IO/Animate.hs b/Graphics/Gloss/Interface/IO/Animate.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/IO/Animate.hs @@ -0,0 +1,29 @@ + +-- | Display mode is for drawing a static picture. +module Graphics.Gloss.Interface.IO.Animate + ( module Graphics.Gloss.Data.Display + , module Graphics.Gloss.Data.Picture + , module Graphics.Gloss.Data.Color + , animateIO) +where +import Graphics.Gloss.Data.Display +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.Animate +import Graphics.Gloss.Internals.Interface.Backend + + +-- | Open a new window and display the given animation. +-- +-- Once the window is open you can use the same commands as with @display@. +-- +animateIO :: Display -- ^ Display mode. + -> 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 () + +animateIO display backColor frameFunIO + = animateWithBackendIO + defaultBackendState display backColor + frameFunIO diff --git a/Graphics/Gloss/Interface/IO/Game.hs b/Graphics/Gloss/Interface/IO/Game.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/IO/Game.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ExplicitForAll #-} + +-- | 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.IO.Game + ( module Graphics.Gloss.Data.Display + , module Graphics.Gloss.Data.Picture + , module Graphics.Gloss.Data.Color + , playIO + , Event(..), Key(..), SpecialKey(..), MouseButton(..)) +where +import Graphics.Gloss.Data.Display +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.Game +import Graphics.Gloss.Internals.Interface.Backend + + +-- | Play a game in a window, using IO actions to build the pictures. +playIO :: 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 -> IO Picture) -- ^ An action to convert the world a picture. + -> (Event -> world -> IO world) -- ^ A function to handle input events. + -> (Float -> world -> IO world) -- ^ A function to step the world one iteration. + -- It is passed the period of time (in seconds) needing to be advanced. + -> IO () + +playIO = playWithBackendIO defaultBackendState diff --git a/Graphics/Gloss/Interface/IO/Simulate.hs b/Graphics/Gloss/Interface/IO/Simulate.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/IO/Simulate.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE RankNTypes #-} + +-- 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.IO.Simulate + ( module Graphics.Gloss.Data.Display + , module Graphics.Gloss.Data.Picture + , module Graphics.Gloss.Data.Color + , simulateIO + , ViewPort(..)) +where +import Graphics.Gloss.Data.Display +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.ViewPort +import Graphics.Gloss.Internals.Interface.Simulate +import Graphics.Gloss.Internals.Interface.Backend + + +simulateIO :: 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 -> 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 () + +simulateIO = simulateWithBackendIO defaultBackendState diff --git a/Graphics/Gloss/Interface/Pure/Animate.hs b/Graphics/Gloss/Interface/Pure/Animate.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/Pure/Animate.hs @@ -0,0 +1,29 @@ + +-- | Display mode is for drawing a static picture. +module Graphics.Gloss.Interface.Pure.Animate + ( module Graphics.Gloss.Data.Display + , module Graphics.Gloss.Data.Picture + , module Graphics.Gloss.Data.Color + , animate) +where +import Graphics.Gloss.Data.Display +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.Animate +import Graphics.Gloss.Internals.Interface.Backend + + +-- | Open a new window and display the given animation. +-- +-- 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. + -- It is passed the time in seconds since the program started. + -> IO () + +animate display backColor frameFun + = animateWithBackendIO + defaultBackendState display backColor + (return . frameFun) diff --git a/Graphics/Gloss/Interface/Pure/Display.hs b/Graphics/Gloss/Interface/Pure/Display.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/Pure/Display.hs @@ -0,0 +1,33 @@ + +-- | Display mode is for drawing a static picture. +module Graphics.Gloss.Interface.Pure.Display + ( module Graphics.Gloss.Data.Display + , module Graphics.Gloss.Data.Picture + , module Graphics.Gloss.Data.Color + , display) +where +import Graphics.Gloss.Data.Display +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 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 diff --git a/Graphics/Gloss/Interface/Pure/Game.hs b/Graphics/Gloss/Interface/Pure/Game.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/Pure/Game.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ExplicitForAll #-} + +-- 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.Picture + , module Graphics.Gloss.Data.Color + , play + , Event(..), Key(..), SpecialKey(..), MouseButton(..), KeyState(..), Modifiers(..)) +where +import Graphics.Gloss.Data.Display +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.Game +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. + -> 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) diff --git a/Graphics/Gloss/Interface/Pure/Simulate.hs b/Graphics/Gloss/Interface/Pure/Simulate.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Interface/Pure/Simulate.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE RankNTypes #-} + +-- 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.Picture + , module Graphics.Gloss.Data.Color + , simulate + , ViewPort(..)) +where +import Graphics.Gloss.Data.Display +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.ViewPort +import Graphics.Gloss.Internals.Interface.Simulate +import Graphics.Gloss.Internals.Interface.Backend + + +-- | 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. +-- This function does the rest. +-- +-- 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). + -> IO () + +simulate display backColor simResolution + modelStart modelToPicture modelStep + + = simulateWithBackendIO defaultBackendState + display backColor simResolution + modelStart + (return . modelToPicture) + (\view time model -> return $ modelStep view time model) + + diff --git a/Graphics/Gloss/Interface/Simulate.hs b/Graphics/Gloss/Interface/Simulate.hs deleted file mode 100644 --- a/Graphics/Gloss/Interface/Simulate.hs +++ /dev/null @@ -1,19 +0,0 @@ - --- 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.Simulate - ( module Graphics.Gloss.Data.Display - , module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color - , simulate - , ViewPort(..)) -where -import Graphics.Gloss.Data.Display -import Graphics.Gloss.Data.Picture -import Graphics.Gloss.Data.Color -import Graphics.Gloss.Internals.Interface.ViewPort -import Graphics.Gloss.Internals.Interface.Simulate diff --git a/Graphics/Gloss/Internals/Interface/Animate.hs b/Graphics/Gloss/Internals/Interface/Animate.hs --- a/Graphics/Gloss/Internals/Interface/Animate.hs +++ b/Graphics/Gloss/Internals/Interface/Animate.hs @@ -1,7 +1,6 @@ module Graphics.Gloss.Internals.Interface.Animate - ( animate - , animateWithBackend) + (animateWithBackendIO) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture @@ -19,36 +18,23 @@ import qualified Graphics.Gloss.Internals.Interface.ViewPort.ControlState as VPC import qualified Graphics.Gloss.Internals.Interface.Animate.State as AN import qualified Graphics.Gloss.Internals.Interface.Callback as Callback - import Data.IORef import Control.Monad import System.Mem import GHC.Float (double2Float) --- | Open a new window and display the given animation. --- --- 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. - -- It is passed the time in seconds since the program started. - -> IO () - -animate = animateWithBackend defaultBackendState - - -animateWithBackend +animateWithBackendIO :: Backend a - => a -- ^ Initial State of the backend - -> Display -- ^ Display mode. - -> Color -- ^ Background color. - -> (Float -> Picture) -- ^ Function to produce the next frame of animation. - -- It is passed the time in seconds since the program started. + => a -- ^ Initial State of the backend + -> Display -- ^ Display mode. + -> 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 () -animateWithBackend backend display backColor frameFun +animateWithBackendIO backend display backColor frameOp = do + -- viewSR <- newIORef viewPortInit viewControlSR <- newIORef VPC.stateInit animateSR <- newIORef AN.stateInit @@ -57,10 +43,10 @@ let displayFun backendRef = do -- extract the current time from the state - timeS <- animateSR `getsIORef` AN.stateAnimateTime + timeS <- animateSR `getsIORef` AN.stateAnimateTime - -- call the user function to get the animation frame - let picture = frameFun (double2Float timeS) + -- call the user action to get the animation frame + picture <- frameOp (double2Float timeS) renderS <- readIORef renderSR viewS <- readIORef viewSR diff --git a/Graphics/Gloss/Internals/Interface/Animate/State.hs b/Graphics/Gloss/Internals/Interface/Animate/State.hs --- a/Graphics/Gloss/Internals/Interface/Animate/State.hs +++ b/Graphics/Gloss/Internals/Interface/Animate/State.hs @@ -12,6 +12,9 @@ -- | 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 @@ -22,10 +25,8 @@ , stateDisplayTime :: Double , stateDisplayTimeLast :: Double - -- | Clamp the minimum time between frames to this value (in msec) - -- Most LCD monitors refresh at around 50Hz so setting - -- this to < 20msec probably isn't worthwhile. - -- + -- | 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. @@ -42,11 +43,12 @@ stateInit = State { stateAnimate = True + , stateAnimateCount = 0 , stateAnimateStart = True , stateAnimateTime = 0 , stateDisplayTime = 0 , stateDisplayTimeLast = 0 - , stateDisplayTimeClamp = 0.02 + , stateDisplayTimeClamp = 0.01 , stateGateTimeStart = 0 , stateGateTimeEnd = 0 , stateGateTimeElapsed = 0 } diff --git a/Graphics/Gloss/Internals/Interface/Animate/Timing.hs b/Graphics/Gloss/Internals/Interface/Animate/Timing.hs --- a/Graphics/Gloss/Internals/Interface/Animate/Timing.hs +++ b/Graphics/Gloss/Internals/Interface/Animate/Timing.hs @@ -32,25 +32,30 @@ { stateDisplayTime = displayTime , stateDisplayTimeLast = displayTimeLast } -{- putStr $ " displayTime = " ++ show displayTime ++ "\n" - ++ " displayTimeLast = " ++ show displayTimeLast ++ "\n" - ++ " displayTimeElapsed = " ++ show displayTimeElapsed ++ "\n" --} - -- increment the animation time - animate <- stateRef `getsIORef` stateAnimate - animateTime <- stateRef `getsIORef` stateAnimateTime - animateStart <- stateRef `getsIORef` stateAnimateStart - + 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) - $ do stateRef `modifyIORef` \s -> s - { stateAnimateTime = animateTime + displayTimeElapsed } + $ stateRef `modifyIORef` \s -> s + { stateAnimateTime = animateTime + displayTimeElapsed } when animate - $ do stateRef `modifyIORef` \s -> s - { stateAnimateStart = False } + $ stateRef `modifyIORef` \s -> s + { stateAnimateCount = animateCount + 1 + , stateAnimateStart = False } + -- | Handles animation timing details. -- Call this function at the end of each frame. animateEnd :: IORef State -> DisplayCallback @@ -61,9 +66,8 @@ gateTimeStart <- elapsedTime backendRef -- the start of this gate gateTimeEnd <- stateRef `getsIORef` stateGateTimeEnd -- end of the previous gate - let gateTimeElapsed - = gateTimeStart - gateTimeEnd - + let gateTimeElapsed = gateTimeStart - gateTimeEnd + when (gateTimeElapsed < timeClamp) $ do sleep backendRef (timeClamp - gateTimeElapsed) diff --git a/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs b/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs --- a/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs +++ b/Graphics/Gloss/Internals/Interface/Backend/GLFW.hs @@ -12,7 +12,7 @@ import Graphics.UI.GLFW (WindowValue(..)) import qualified Graphics.UI.GLFW as GLFW import qualified Graphics.Rendering.OpenGL as GL - +import qualified Control.Excpetion as X -- [Note: FreeGlut] -- ~~~~~~~~~~~~~~~~ @@ -434,9 +434,19 @@ -> IO () runMainLoopGLFW stateRef - = do windowIsOpen <- GLFW.windowIsOpen - when windowIsOpen - $ do dirty <- fmap dirtyScreen $ readIORef stateRef + = X.catch go recover + where + recover :: SomeException -> IO ()x + recover = do +#ifdef linux_HOST_OS +-- See [Note: FreeGlut] for why we need this. + GLUT.exit +#endif + return True + go :: IO () + go = do windowIsOpen <- GLFW.windowIsOpen + when windowIsOpen + $ do dirty <- fmap dirtyScreen $ readIORef stateRef when dirty $ do s <- readIORef stateRef diff --git a/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs b/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs --- a/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs +++ b/Graphics/Gloss/Internals/Interface/Backend/GLUT.hs @@ -59,7 +59,7 @@ return $ (fromIntegral t) / 1000 sleep _ sec - = do threadDelay (round $ sec * 100000) + = do threadDelay (round $ sec * 1000000) -- Initialise ----------------------------------------------------------------- @@ -318,7 +318,6 @@ GLUT.MouseButton GLUT.WheelUp -> MouseButton WheelUp GLUT.MouseButton GLUT.WheelDown -> MouseButton WheelDown GLUT.MouseButton (GLUT.AdditionalButton i) -> MouseButton (AdditionalButton i) - -- | Convert GLUTs key states to our internal ones. glutKeyStateToKeyState :: GLUT.KeyState -> KeyState diff --git a/Graphics/Gloss/Internals/Interface/Display.hs b/Graphics/Gloss/Internals/Interface/Display.hs --- a/Graphics/Gloss/Internals/Interface/Display.hs +++ b/Graphics/Gloss/Internals/Interface/Display.hs @@ -1,7 +1,6 @@ module Graphics.Gloss.Internals.Interface.Display - ( display - , displayWithBackend) + (displayWithBackend) where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture @@ -20,26 +19,7 @@ import Data.IORef --- | 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 - - displayWithBackend :: Backend a => a -- ^ Initial state of the backend. @@ -65,10 +45,6 @@ let callbacks = [ Callback.Display renderFun - - -- Delay the thread for a bit to give the runtime - -- a chance to switch back to the OS. - , Callback.Idle (\stateRef -> sleep stateRef 0.001 >> postRedisplay stateRef) -- Escape exits the program , callback_exit () diff --git a/Graphics/Gloss/Internals/Interface/Game.hs b/Graphics/Gloss/Internals/Interface/Game.hs --- a/Graphics/Gloss/Internals/Interface/Game.hs +++ b/Graphics/Gloss/Internals/Interface/Game.hs @@ -1,8 +1,7 @@ {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Game - ( play - , playWithBackend + ( playWithBackendIO , Event(..)) where import Graphics.Gloss.Data.Color @@ -29,21 +28,8 @@ | EventMotion (Float, Float) deriving (Eq, Show) --- | 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. - -> IO () -play = playWithBackend defaultBackendState - -playWithBackend +playWithBackendIO :: forall world a . Backend a => a -- ^ Initial state of the backend @@ -51,13 +37,13 @@ -> 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. + -> (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. -> IO () -playWithBackend +playWithBackendIO backend display backgroundColor @@ -85,7 +71,7 @@ = do -- convert the world to a picture world <- readIORef worldSR - let picture = worldToPicture world + picture <- worldToPicture world -- display the picture in the current view renderS <- readIORef renderSR @@ -120,7 +106,7 @@ callback_keyMouse :: IORef world -- ^ ref to world state -> IORef ViewPort - -> (Event -> world -> world) -- ^ fn to handle input events + -> (Event -> world -> IO world) -- ^ fn to handle input events -> Callback callback_keyMouse worldRef viewRef eventFn @@ -130,18 +116,20 @@ handle_keyMouse :: IORef a -> t - -> (Event -> a -> a) + -> (Event -> a -> IO a) -> KeyboardMouseCallback handle_keyMouse worldRef _ eventFn backendRef key keyState keyMods pos - = do pos' <- convertPoint backendRef pos - worldRef `modifyIORef` \world -> eventFn (EventKey key keyState keyMods pos') world + = do pos' <- convertPoint backendRef pos + world <- readIORef worldRef + world' <- eventFn (EventKey key keyState keyMods pos') world + writeIORef worldRef world' -- | Callback for Motion events. callback_motion :: IORef world -- ^ ref to world state - -> (Event -> world -> world) -- ^ fn to handle input events + -> (Event -> world -> IO world) -- ^ fn to handle input events -> Callback callback_motion worldRef eventFn @@ -150,12 +138,14 @@ handle_motion :: IORef a - -> (Event -> a -> a) + -> (Event -> a -> IO a) -> MotionCallback handle_motion worldRef eventFn backendRef pos - = do pos' <- convertPoint backendRef pos - worldRef `modifyIORef` \world -> eventFn (EventMotion pos') world + = do pos' <- convertPoint backendRef pos + world <- readIORef worldRef + world' <- eventFn (EventMotion pos') world + writeIORef worldRef world' convertPoint :: diff --git a/Graphics/Gloss/Internals/Interface/Simulate.hs b/Graphics/Gloss/Internals/Interface/Simulate.hs --- a/Graphics/Gloss/Internals/Interface/Simulate.hs +++ b/Graphics/Gloss/Internals/Interface/Simulate.hs @@ -1,8 +1,7 @@ {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Simulate - ( simulate - , simulateWithBackend) + (simulateWithBackendIO) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Color @@ -26,26 +25,8 @@ import Data.IORef import System.Mem --- | 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. --- This function does the rest. --- --- 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). - -> IO () -simulate = simulateWithBackend defaultBackendState - -simulateWithBackend +simulateWithBackendIO :: forall model a . Backend a => a -- ^ Initial state of the backend @@ -53,13 +34,13 @@ -> 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 + -> (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 () -simulateWithBackend +simulateWithBackendIO backend display backgroundColor @@ -87,7 +68,7 @@ = do -- convert the world to a picture world <- readIORef worldSR - let picture = worldToPicture world + picture <- worldToPicture world -- display the picture in the current view renderS <- readIORef renderSR diff --git a/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs b/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs --- a/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs +++ b/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs @@ -21,7 +21,7 @@ -> IORef ViewPort -- ^ the viewport state -> IORef world -- ^ the current world -> world -- ^ the initial world - -> (ViewPort -> Float -> world -> world) -- ^ fn to advance the world + -> (ViewPort -> Float -> world -> IO world) -- ^ fn to advance the world -> Float -- ^ how much time to advance world by -- in single step mode -> IdleCallback @@ -64,7 +64,7 @@ -> IORef AN.State -> IORef ViewPort -> IORef world - -> (ViewPort -> Float -> world -> world) + -> (ViewPort -> Float -> world -> IO world) -> IdleCallback simulate_run simSR _ viewSR worldSR worldAdvance backendRef @@ -103,11 +103,10 @@ let nFinal = nStart + thisSteps -- keep advancing the world until we get to the final iteration number - let (_, world') = - until (\(n, _) -> n >= nFinal) - (\(n, w) -> (n+1, worldAdvance viewS timePerStep w)) - (nStart, worldS) - + (_,world') <- untilM (\(n, _) -> n >= nFinal) + (\(n, w) -> liftM (\w' -> (n+1,w')) ( worldAdvance viewS timePerStep w)) + (nStart, worldS) + -- 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' @@ -127,7 +126,7 @@ :: IORef SM.State -> IORef ViewPort -> IORef world - -> (ViewPort -> Float -> world -> world) + -> (ViewPort -> Float -> world -> IO world) -> Float -> IdleCallback @@ -135,7 +134,7 @@ = do viewS <- readIORef viewSR world <- readIORef worldSR - let world' = worldAdvance viewS singleStepTime world + world' <- worldAdvance viewS singleStepTime world writeIORef worldSR world' simSR `modifyIORef` \c -> c @@ -148,3 +147,10 @@ getsIORef :: IORef a -> (a -> r) -> IO r getsIORef ref fun = liftM fun $ readIORef ref + +untilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a +untilM test op i = go i + where + go x | test x = return x + | otherwise = op x >>= go + diff --git a/Graphics/Gloss/Internals/Render/Bitmap.hs b/Graphics/Gloss/Internals/Render/Bitmap.hs --- a/Graphics/Gloss/Internals/Render/Bitmap.hs +++ b/Graphics/Gloss/Internals/Render/Bitmap.hs @@ -11,7 +11,7 @@ import Foreign --- | Abstract bitmap data. +-- | Abstract 32-bit RGBA bitmap data. data BitmapData = BitmapData Int -- length (in bytes) diff --git a/Graphics/Gloss/Internals/Render/Circle.hs b/Graphics/Gloss/Internals/Render/Circle.hs --- a/Graphics/Gloss/Internals/Render/Circle.hs +++ b/Graphics/Gloss/Internals/Render/Circle.hs @@ -2,90 +2,245 @@ {-# OPTIONS_HADDOCK hide #-} -- | Fast(ish) rendering of circles. -module Graphics.Gloss.Internals.Render.Circle where - +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 --- | Render a circle with the given thickness -renderCircle :: Float -> Float -> Float -> Float -> Float -> IO () -renderCircle posX posY scaleFactor radius thickness - | radScreen <- scaleFactor * radius - , steps <- circleSteps (2 * radScreen) - = if thickness == 0 - then renderCircleLine posX posY steps radius - else renderCircleStrip posX posY steps radius thickness - --- | Decide how many line segments to use to render the circle +-- | 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 < 1 = 1 - | sDiam < 2 = 4 - | sDiam < 10 = 8 - | sDiam < 20 = 16 - | sDiam < 30 = 32 - | otherwise = 40 + | sDiam < 8 = 8 + | sDiam < 16 = 16 + | sDiam < 32 = 32 + | otherwise = 64 -renderCircleLine_step :: Float# -> Float# -> Float# -> Float# -> Float# -> Float# -> IO () -renderCircleLine_step posX posY tStep tStop rad tt - | tt `geFloat#` tStop - = return () - - | otherwise - = do GL.vertex - $ GL.Vertex2 - (gf $ F# (posX `plusFloat#` (rad `timesFloat#` (cosFloat# tt)))) - (gf $ F# (posY `plusFloat#` (rad `timesFloat#` (sinFloat# tt)))) +-- 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 - renderCircleLine_step posX posY tStep tStop rad (tt `plusFloat#` tStep) + -- 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) + = 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# + 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 + = 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# tStop) = (2 * pi) + (F# tStep) / 2 - !(F# r1) = r - width / 2 - !(F# r2) = r + width / 2 + !(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 - $ renderCircleStrip_step posX posY tStep tStop r1 0.0# r2 - (tStep `divideFloat#` 2.0#) - + $ 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 + | 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 () + -> Float# -> Float# + -> Float# -> Float# -> IO () renderCircleStrip_step posX posY tStep tStop r1 t1 r2 t2 | t1 `geFloat#` tStop = return () | otherwise - = do GL.vertex - $ GL.Vertex2 - (gf $ F# (posX `plusFloat#` (r1 `timesFloat#` (cosFloat# t1)))) - (gf $ F# (posY `plusFloat#` (r1 `timesFloat#` (sinFloat# t1)))) - - GL.vertex - $ GL.Vertex2 - (gf $ F# (posX `plusFloat#` (r2 `timesFloat#` (cosFloat# t2)))) - (gf $ F# (posY `plusFloat#` (r2 `timesFloat#` (sinFloat# t2)))) - + = do addPointOnCircle posX posY r1 t1 + addPointOnCircle posX posY r2 t2 renderCircleStrip_step posX posY tStep tStop r1 (t1 `plusFloat#` tStep) r2 (t2 `plusFloat#` tStep) - +{-# INLINE renderCircleStrip_step #-} + + +addPoint :: Float# -> Float# -> IO () +addPoint x y = + GL.vertex $ GL.Vertex2 (gf (F# x)) (gf (F# y)) +{-# INLINE addPoint #-} + + +addPointOnCircle :: Float# -> Float# -> Float# -> Float# -> IO () +addPointOnCircle posX posY rad tt = + addPoint + (posX `plusFloat#` (rad `timesFloat#` (cosFloat# tt))) + (posY `plusFloat#` (rad `timesFloat#` (sinFloat# tt))) +{-# INLINE addPointOnCircle #-} + + + +{- Unused sector drawing code. + Sectors are currently drawn as compound Pictures, + but we might want this if we end up implementing the ThickSector + version as well. + +-- | Render a sector as a line. +renderSectorLine :: Float -> Float -> Int -> Float -> Float -> Float -> IO () +renderSectorLine pX@(F# posX) pY@(F# posY) steps (F# rad) a1 a2 + = let n = fromIntegral steps + !(F# tStep) = (2 * pi) / n + !(F# tStart) = degToRad a1 + !(F# tStop) = degToRad a2 + if a1 >= a2 then 2 * pi else 0 + + -- need to set up the edges of the start/end triangles + startVertex = GL.vertex $ GL.Vertex2 (gf pX) (gf pY) + endVertex = addPointOnCircle posX posY rad tStop + + in GL.renderPrimitive GL.LineLoop + $ do startVertex + renderCircleLine_step posX posY tStep tStop rad tStart + endVertex + +-- | Render a sector. +renderSector :: Float -> Float -> Float -> Float -> Float -> Float -> IO () +renderSector posX posY scaleFactor radius a1 a2 + | radScreen <- scaleFactor * radius + , steps <- circleSteps (2 * radScreen) + = renderSectorLine posX posY steps radius a1 a2 +-} + diff --git a/Graphics/Gloss/Internals/Render/Picture.hs b/Graphics/Gloss/Internals/Render/Picture.hs --- a/Graphics/Gloss/Internals/Render/Picture.hs +++ b/Graphics/Gloss/Internals/Render/Picture.hs @@ -3,27 +3,27 @@ {-# LANGUAGE ImplicitParams, ScopedTypeVariables #-} module Graphics.Gloss.Internals.Render.Picture - ( renderPicture ) + (renderPicture) where -import Graphics.Gloss.Data.Picture -import Graphics.Gloss.Data.Color -import Graphics.Gloss.Internals.Interface.Backend -import Graphics.Gloss.Internals.Interface.ViewPort -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.UI.GLUT as GLUT +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Internals.Interface.Backend +import Graphics.Gloss.Internals.Interface.ViewPort +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.UI.GLUT as GLUT --- ^ Render a picture using the given render options and viewport. +-- | Render a picture using the given render options and viewport. renderPicture :: forall a . Backend a => IORef a @@ -41,7 +41,7 @@ -- 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) + <- get $ GL.matrix (Just GL.Projection) viewport_ <- get $ GL.viewport windowSize_ <- getWindowDimensions backendRef @@ -57,8 +57,9 @@ setLineSmooth (stateLineSmooth renderS) setBlendAlpha (stateBlendAlpha renderS) - drawPicture (viewPortScale viewS) picture + drawPicture (viewPortScale viewS) picture + drawPicture :: ( ?modeWireframe :: Bool , ?modeColor :: Bool @@ -96,6 +97,13 @@ 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. @@ -108,8 +116,7 @@ -- colors with float components. Color col p | ?modeColor - -> {-# SCC "draw.color" #-} - do oldColor <- get GL.currentColor + -> do oldColor <- get GL.currentColor let (r, g, b, a) = rgbaOfColor col @@ -121,39 +128,61 @@ -> drawPicture circScale p - -- ease up on GL.preservingMatrix - -- This is an important optimisation for the Eden example, - -- as it draws lots of translated circles. + -- 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)) + 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, @@ -177,7 +206,7 @@ -- Draw textured polygon GL.renderPrimitive GL.Polygon - $ do zipWithM_ + $ zipWithM_ (\(pX, pY) (tX, tY) -> do GL.texCoord $ GL.TexCoord2 (gf tX) (gf tY) GL.vertex $ GL.Vertex2 (gf pX) (gf pY)) @@ -214,7 +243,7 @@ = find (\tex -> texName tex == name && texWidth tex == width && texHeight tex == height) - $ textures + textures case mTexCached of Just tex diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2010-2011 Benjamin Lippmeier +Copyright (c) 2010-2012 Benjamin Lippmeier Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation diff --git a/gloss.cabal b/gloss.cabal --- a/gloss.cabal +++ b/gloss.cabal @@ -1,5 +1,5 @@ Name: gloss -Version: 1.6.2.1 +Version: 1.7.0.1 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -59,10 +59,13 @@ Graphics.Gloss.Data.Color Graphics.Gloss.Data.Picture Graphics.Gloss.Algorithms.RayCast - Graphics.Gloss.Interface.Display - Graphics.Gloss.Interface.Animate - Graphics.Gloss.Interface.Simulate - Graphics.Gloss.Interface.Game + 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.Simulate + Graphics.Gloss.Interface.IO.Game Other-modules: Graphics.Gloss.Internals.Color