diff --git a/Graphics/Gloss.hs b/Graphics/Gloss.hs --- a/Graphics/Gloss.hs +++ b/Graphics/Gloss.hs @@ -1,6 +1,6 @@ -- | 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: -- @@ -11,13 +11,13 @@ -- -- 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 - left-click drag, arrow keys. -- --- * Rotate Viewport - right-click drag, control-left-click drag, or home\/end-keys. +-- * Rotate Viewport - right-click drag, control-left-click drag, or home\/end-keys. -- --- * Zoom Viewport - mouse wheel, or page up\/down-keys. +-- * Zoom Viewport - mouse wheel, or page up\/down-keys. -- -- Animations can be constructed similarly using the `animate`. -- @@ -66,14 +66,14 @@ -- For more information, check out . -- module Graphics.Gloss - ( module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color + ( 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 diff --git a/Graphics/Gloss/Data/Color.hs b/Graphics/Gloss/Data/Color.hs --- a/Graphics/Gloss/Data/Color.hs +++ b/Graphics/Gloss/Data/Color.hs @@ -1,30 +1,30 @@ -- | Predefined and custom colors. module Graphics.Gloss.Data.Color - ( -- ** Color data type - Color + ( -- ** 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 + -- ** Pre-defined colors + , greyN, black, white - -- *** Primary - , red, green, blue + -- *** Primary + , red, green, blue - -- *** Secondary - , yellow, cyan, magenta - - -- *** Tertiary - , rose, violet, azure, aquamarine, chartreuse, orange - ) + -- *** Secondary + , yellow, cyan, magenta + + -- *** Tertiary + , rose, violet, azure, aquamarine, chartreuse, orange + ) where import Graphics.Gloss.Rendering @@ -41,40 +41,40 @@ -- | 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. + :: Float -- ^ Ratio of first color. + -> Float -- ^ Ratio of second color. + -> Color -- ^ First color. + -> Color -- ^ Second color. + -> Color -- ^ Resulting color. mixColors ratio1 ratio2 c1 c2 - = let (r1, g1, b1, a1) = rgbaOfColor c1 - (r2, g2, b2, a2) = rgbaOfColor c2 + = let (r1, g1, b1, a1) = rgbaOfColor c1 + (r2, g2, b2, a2) = rgbaOfColor c2 - total = ratio1 + ratio2 - m1 = ratio1 / total - m2 = ratio2 / total + total = ratio1 + ratio2 + m1 = ratio1 / total + m2 = ratio2 / total - in makeColor + in makeColor (m1 * r1 + m2 * r2) - (m1 * g1 + m2 * g2) - (m1 * b1 + m2 * b2) - (m1 * a1 + m2 * a2) + (m1 * g1 + m2 * g2) + (m1 * b1 + m2 * b2) + (m1 * a1 + m2 * a2) -- | Add RGB components of a color component-wise, then normalise --- them to the highest resulting one. The alpha components are averaged. +-- them to the highest resulting one. The alpha components are averaged. addColors :: Color -> Color -> Color addColors c1 c2 - = let (r1, g1, b1, a1) = rgbaOfColor c1 - (r2, g2, b2, a2) = rgbaOfColor c2 + = let (r1, g1, b1, a1) = rgbaOfColor c1 + (r2, g2, b2, a2) = rgbaOfColor c2 - in normalizeColor - $ makeColor + in normalizeColor + $ makeColor (r1 + r2) - (g1 + g2) - (b1 + b2) - ((a1 + a2) / 2) + (g1 + g2) + (b1 + b2) + ((a1 + a2) / 2) -- | Make a dimmer version of a color, scaling towards black. @@ -83,7 +83,7 @@ = 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 c @@ -96,8 +96,8 @@ 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 c @@ -107,31 +107,31 @@ -- Pre-defined Colors --------------------------------------------------------- -- | A greyness of a given order. -greyN :: Float -- ^ Range is 0 = black, to 1 = white. - -> Color -greyN n = makeRawColor n n n 1.0 +greyN :: Float -- ^ Range is 0 = black, to 1 = white. + -> Color +greyN n = makeRawColor n n n 1.0 black, white :: Color -black = makeRawColor 0.0 0.0 0.0 1.0 -white = makeRawColor 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 = 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 +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 diff --git a/Graphics/Gloss/Data/Point.hs b/Graphics/Gloss/Data/Point.hs --- a/Graphics/Gloss/Data/Point.hs +++ b/Graphics/Gloss/Data/Point.hs @@ -1,8 +1,8 @@ {-# OPTIONS -fno-warn-missing-methods -fno-warn-orphans #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Graphics.Gloss.Data.Point - ( Point, Path - , pointInBox) + ( Point, Path + , pointInBox) where import Graphics.Gloss.Data.Picture @@ -20,12 +20,12 @@ -- @ -- pointInBox - :: Point - -> Point - -> Point -> Bool - + :: Point + -> Point + -> Point -> Bool + pointInBox (x0, y0) (x1, y1) (x2, y2) - = x0 >= min x1 x2 - && x0 <= max x1 x2 - && y0 >= min y1 y2 - && y0 <= max y1 y2 + = x0 >= min x1 x2 + && x0 <= max x1 x2 + && y0 >= min y1 y2 + && y0 <= max y1 y2 diff --git a/Graphics/Gloss/Data/Vector.hs b/Graphics/Gloss/Data/Vector.hs --- a/Graphics/Gloss/Data/Vector.hs +++ b/Graphics/Gloss/Data/Vector.hs @@ -3,16 +3,16 @@ -- | Geometric functions concerning vectors. module Graphics.Gloss.Data.Vector - ( Vector - , magV - , argV - , dotV - , detV - , mulSV - , rotateV - , angleVV - , normalizeV - , unitVectorAtAngle ) + ( Vector + , magV + , argV + , dotV + , detV + , mulSV + , rotateV + , angleVV + , normalizeV + , unitVectorAtAngle ) where import Graphics.Gloss.Data.Picture import Graphics.Gloss.Geometry.Angle @@ -20,43 +20,43 @@ -- | 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) - = normalizeAngle $ 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 #-} @@ -64,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. normalizeV :: Vector -> Vector -normalizeV v = mulSV (1 / magV v) v +normalizeV v = mulSV (1 / magV v) v {-# INLINE normalizeV #-} -- | Produce a unit vector at a given angle relative to the +ve x-axis. --- The provided angle is in radians. +-- The provided angle is in radians. unitVectorAtAngle :: Float -> Vector unitVectorAtAngle r - = (cos r, sin r) + = (cos r, sin r) {-# INLINE unitVectorAtAngle #-} diff --git a/Graphics/Gloss/Geometry/Angle.hs b/Graphics/Gloss/Geometry/Angle.hs --- a/Graphics/Gloss/Geometry/Angle.hs +++ b/Graphics/Gloss/Geometry/Angle.hs @@ -1,19 +1,19 @@ -- | Geometric functions concerning angles. If not otherwise specified, all angles are in radians. module Graphics.Gloss.Geometry.Angle - ( degToRad - , radToDeg - , normalizeAngle ) + ( degToRad + , radToDeg + , normalizeAngle ) where -- | Convert degrees to radians degToRad :: Float -> Float -degToRad d = d * pi / 180 +degToRad d = d * pi / 180 {-# INLINE degToRad #-} -- | Convert radians to degrees radToDeg :: Float -> Float -radToDeg r = r * 180 / pi +radToDeg r = r * 180 / pi {-# INLINE radToDeg #-} 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 @@ -5,25 +5,25 @@ -- 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 + ( 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 @@ -31,39 +31,39 @@ -- | 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 + :: 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 + (u `mulSV` (p2 - 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 @@ -83,14 +83,14 @@ -- {-# 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 - p1) `dotV` (p2 - p1) + / (p2 - p1) `dotV` (p2 - p1) @@ -111,30 +111,30 @@ -- @ -- intersectLineLine - :: Point -- ^ `P1` - -> Point -- ^ `P2` - -> Point -- ^ `P3` - -> Point -- ^ `P4` - -> Maybe Point + :: 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 -------------------------------------------------- @@ -142,22 +142,22 @@ -- 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. -- @@ -170,30 +170,30 @@ -- @ -- intersectSegHorzLine - :: Point -- ^ P1 First point of segment. - -> Point -- ^ P2 Second point of segment. - -> Float -- ^ y value of line. - -> Maybe Point + :: 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) @@ -210,31 +210,31 @@ -- @ -- intersectSegVertLine - :: Point -- ^ P1 First point of segment. - -> Point -- ^ P2 Second point of segment. - -> Float -- ^ x value of line. - -> Maybe Point + :: 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 ----------------------------------------------- @@ -242,23 +242,23 @@ -- | 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. @@ -272,23 +272,23 @@ -- @ 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. @@ -304,22 +304,22 @@ -- @ intersectSegVertSeg - :: Point -- ^ P1 First point of segment. - -> Point -- ^ P2 Second point of segment. - -> Float -- ^ (x3) x value of vertical segment - -> Float -- ^ (ya) Lowest y value of vertical segment. - -> Float -- ^ (yb) Highest y value of vertical segment. - -> Maybe Point -- ^ (x3, y3) Intersection point, if any. + :: Point -- ^ P1 First point of segment. + -> Point -- ^ P2 Second point of segment. + -> Float -- ^ (x3) x value of vertical segment + -> Float -- ^ (ya) Lowest y value of vertical segment. + -> Float -- ^ (yb) Highest y value of vertical segment. + -> Maybe Point -- ^ (x3, y3) Intersection point, if any. intersectSegVertSeg p1@(x1, y1) p2@(x2, y2) x0 ya yb - | segClearsBox p1 p2 (x0, ya) (x0, yb) - = Nothing - - | y0 < ya = Nothing - | y0 > yb = Nothing - | otherwise = Just (x0, y0) - - where y0 | (x2 - x1) == 0 = y1 - | otherwise = (x0 - x1) * (y2 - y1) / (x2 - x1) + y1 + | segClearsBox p1 p2 (x0, ya) (x0, yb) + = Nothing + + | y0 < ya = Nothing + | y0 > yb = Nothing + | otherwise = Just (x0, y0) + + where y0 | (x2 - x1) == 0 = y1 + | otherwise = (x0 - x1) * (y2 - y1) / (x2 - x1) + y1 diff --git a/Graphics/Gloss/Interface/Pure/Animate.hs b/Graphics/Gloss/Interface/Pure/Animate.hs --- a/Graphics/Gloss/Interface/Pure/Animate.hs +++ b/Graphics/Gloss/Interface/Pure/Animate.hs @@ -1,10 +1,10 @@ -- | Display mode is for drawing a static picture. module Graphics.Gloss.Interface.Pure.Animate - ( module Graphics.Gloss.Data.Display + ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color - , animate) + , module Graphics.Gloss.Data.Color + , animate) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture diff --git a/Graphics/Gloss/Interface/Pure/Display.hs b/Graphics/Gloss/Interface/Pure/Display.hs --- a/Graphics/Gloss/Interface/Pure/Display.hs +++ b/Graphics/Gloss/Interface/Pure/Display.hs @@ -1,10 +1,10 @@ -- | Display mode is for drawing a static picture. module Graphics.Gloss.Interface.Pure.Display - ( module Graphics.Gloss.Data.Display + ( module Graphics.Gloss.Data.Display , module Graphics.Gloss.Data.Picture - , module Graphics.Gloss.Data.Color - , display) + , module Graphics.Gloss.Data.Color + , display) where import Graphics.Gloss.Data.Display import Graphics.Gloss.Data.Picture diff --git a/Graphics/Gloss/Interface/Pure/Game.hs b/Graphics/Gloss/Interface/Pure/Game.hs --- a/Graphics/Gloss/Interface/Pure/Game.hs +++ b/Graphics/Gloss/Interface/Pure/Game.hs @@ -6,11 +6,11 @@ -- | 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 diff --git a/Graphics/Gloss/Interface/Pure/Simulate.hs b/Graphics/Gloss/Interface/Pure/Simulate.hs --- a/Graphics/Gloss/Interface/Pure/Simulate.hs +++ b/Graphics/Gloss/Interface/Pure/Simulate.hs @@ -7,10 +7,10 @@ -- 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 diff --git a/Graphics/Gloss/Internals/Color.hs b/Graphics/Gloss/Internals/Color.hs --- a/Graphics/Gloss/Internals/Color.hs +++ b/Graphics/Gloss/Internals/Color.hs @@ -3,7 +3,7 @@ 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 @@ -11,9 +11,9 @@ glColor4OfColor :: Fractional a => Color -> GL.Color4 a glColor4OfColor color = case rgbaOfColor color of - (r, g, b, a) - -> let rF = unsafeCoerce r - gF = unsafeCoerce g - bF = unsafeCoerce b - aF = unsafeCoerce a - in GL.Color4 rF gF bF aF + (r, g, b, a) + -> let rF = unsafeCoerce r + gF = unsafeCoerce g + bF = unsafeCoerce b + aF = unsafeCoerce a + in GL.Color4 rF gF bF aF diff --git a/Graphics/Gloss/Internals/Interface/Animate.hs b/Graphics/Gloss/Internals/Interface/Animate.hs --- a/Graphics/Gloss/Internals/Interface/Animate.hs +++ b/Graphics/Gloss/Internals/Interface/Animate.hs @@ -1,7 +1,7 @@ module Graphics.Gloss.Internals.Interface.Animate - (animateWithBackendIO) -where + (animateWithBackendIO) +where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.ViewPort @@ -14,63 +14,63 @@ 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.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 () + -> IO () animateWithBackendIO backend pannable display backColor frameOp - = do + = do -- - viewSR <- newIORef viewStateInit - animateSR <- newIORef AN.stateInit + viewSR <- newIORef viewStateInit + animateSR <- newIORef AN.stateInit renderS_ <- initState - renderSR <- newIORef renderS_ + 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 windowSize <- getWindowDimensions backendRef - -- render the frame - displayPicture - windowSize + -- render the frame + displayPicture + windowSize backColor renderS (viewPortScale portS) (applyViewPortToPicture portS picture) - -- perform GC every frame to try and avoid long pauses - performGC + -- 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 ] + 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] diff --git a/Graphics/Gloss/Internals/Interface/Animate/State.hs b/Graphics/Gloss/Internals/Interface/Animate/State.hs --- a/Graphics/Gloss/Internals/Interface/Animate/State.hs +++ b/Graphics/Gloss/Internals/Interface/Animate/State.hs @@ -1,54 +1,54 @@ {-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.Animate.State - ( State (..) - , stateInit ) + ( State (..) + , stateInit ) where -- | Animation State data State - = State - { - -- | Whether the animation is running. - stateAnimate :: !Bool + = State + { + -- | Whether the animation is running. + stateAnimate :: !Bool -- | How many times we've entered the animation loop. , stateAnimateCount :: !Integer - -- | Whether this is the first frame of the animation. - , stateAnimateStart :: !Bool + -- | Whether this is the first frame of the animation. + , stateAnimateStart :: !Bool - -- | Number of msec the animation has been running for - , stateAnimateTime :: !Double + -- | Number of msec the animation has been running for + , stateAnimateTime :: !Double - -- | The time when we entered the display callback for the current frame. - , stateDisplayTime :: !Double - , stateDisplayTimeLast :: !Double + -- | The time when we entered the display callback for the current frame. + , stateDisplayTime :: !Double + , stateDisplayTimeLast :: !Double - -- | Clamp the minimum time between frames to this value (in seconds) + -- | Clamp the minimum time between frames to this value (in seconds) -- Setting this to < 10ms probably isn't worthwhile. - , stateDisplayTimeClamp :: !Double - - -- | The time when the last call to the users render function finished. - , stateGateTimeStart :: !Double + , stateDisplayTimeClamp :: !Double + + -- | The time when 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 } + -- | The time when displayInWindow last finished (after sleeping to clamp fps). + , stateGateTimeEnd :: !Double + + -- | How long it took to draw this frame + , stateGateTimeElapsed :: !Double } stateInit :: State stateInit - = State - { stateAnimate = True + = State + { stateAnimate = True , stateAnimateCount = 0 - , stateAnimateStart = True - , stateAnimateTime = 0 - , stateDisplayTime = 0 - , stateDisplayTimeLast = 0 - , stateDisplayTimeClamp = 0.01 - , stateGateTimeStart = 0 - , stateGateTimeEnd = 0 - , stateGateTimeElapsed = 0 } + , stateAnimateStart = True + , stateAnimateTime = 0 + , stateDisplayTime = 0 + , stateDisplayTimeLast = 0 + , stateDisplayTimeClamp = 0.01 + , stateGateTimeStart = 0 + , stateGateTimeEnd = 0 + , stateGateTimeElapsed = 0 } diff --git a/Graphics/Gloss/Internals/Interface/Animate/Timing.hs b/Graphics/Gloss/Internals/Interface/Animate/Timing.hs --- a/Graphics/Gloss/Internals/Interface/Animate/Timing.hs +++ b/Graphics/Gloss/Internals/Interface/Animate/Timing.hs @@ -2,16 +2,16 @@ {-# OPTIONS_HADDOCK hide #-} -- | Handles timing of animation. --- The main point is that we want to restrict the framerate to something --- sensible, instead of just displaying at the machines maximum possible --- rate and soaking up 100% cpu. +-- The main point is that we want to restrict the framerate to something +-- sensible, instead of just displaying at the machines maximum possible +-- rate and soaking up 100% cpu. -- --- We also keep track of the elapsed time since the start of the program, --- so we can pass this to the user's animation function. +-- We also keep track of the elapsed time since the start of the program, +-- so we can pass this to the user's animation function. -- module Graphics.Gloss.Internals.Interface.Animate.Timing - ( animateBegin - , animateEnd ) + ( animateBegin + , animateEnd ) where import Graphics.Gloss.Internals.Interface.Backend import Graphics.Gloss.Internals.Interface.Animate.State @@ -20,62 +20,62 @@ -- | 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 } + stateRef `modifyIORef` \s -> s + { stateDisplayTime = displayTime + , stateDisplayTimeLast = displayTimeLast } - -- increment the animation time - animate <- stateRef `getsIORef` stateAnimate + -- increment the animation time + animate <- stateRef `getsIORef` stateAnimate animateCount <- stateRef `getsIORef` stateAnimateCount - animateTime <- stateRef `getsIORef` stateAnimateTime - animateStart <- stateRef `getsIORef` stateAnimateStart + 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) + $ stateRef `modifyIORef` \s -> s + { stateAnimateTime = animateTime + displayTimeElapsed } + + when animate + $ stateRef `modifyIORef` \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 + gateTimeStart <- elapsedTime backendRef -- the start of this gate + gateTimeEnd <- stateRef `getsIORef` stateGateTimeEnd -- end of the previous gate + let gateTimeElapsed = gateTimeStart - gateTimeEnd - when (gateTimeElapsed < timeClamp) - $ do sleep backendRef (timeClamp - gateTimeElapsed) + when (gateTimeElapsed < timeClamp) + $ do sleep backendRef (timeClamp - gateTimeElapsed) - gateTimeFinal <- elapsedTime backendRef + gateTimeFinal <- elapsedTime backendRef - stateRef `modifyIORef` \s -> s - { stateGateTimeEnd = gateTimeFinal - , stateGateTimeElapsed = gateTimeElapsed } + stateRef `modifyIORef` \s -> s + { stateGateTimeEnd = gateTimeFinal + , stateGateTimeElapsed = gateTimeElapsed } getsIORef :: IORef a -> (a -> r) -> IO r diff --git a/Graphics/Gloss/Internals/Interface/Common/Exit.hs b/Graphics/Gloss/Internals/Interface/Common/Exit.hs --- a/Graphics/Gloss/Internals/Interface/Common/Exit.hs +++ b/Graphics/Gloss/Internals/Interface/Common/Exit.hs @@ -3,23 +3,23 @@ -- | Callback for exiting the program. module Graphics.Gloss.Internals.Interface.Common.Exit - (callback_exit) + (callback_exit) where import Graphics.Gloss.Internals.Interface.Backend.Types callback_exit :: a -> Callback callback_exit stateRef - = KeyMouse (keyMouse_exit stateRef) + = KeyMouse (keyMouse_exit stateRef) keyMouse_exit :: a -> KeyboardMouseCallback keyMouse_exit - _ - backend - key keyState _ - _ - | key == SpecialKey KeyEsc - , keyState == Down - = exitBackend backend - - | otherwise - = return () + _ + backend + key keyState _ + _ + | key == SpecialKey KeyEsc + , keyState == Down + = exitBackend backend + + | otherwise + = return () diff --git a/Graphics/Gloss/Internals/Interface/Debug.hs b/Graphics/Gloss/Internals/Interface/Debug.hs --- a/Graphics/Gloss/Internals/Interface/Debug.hs +++ b/Graphics/Gloss/Internals/Interface/Debug.hs @@ -1,67 +1,67 @@ {-# OPTIONS_HADDOCK hide #-} -- | Implements functions to dump portions of the OpenGL state to stdout. --- Used for debugging. +-- Used for debugging. module Graphics.Gloss.Internals.Interface.Debug - ( dumpFramebufferState - , dumpFragmentState ) + ( dumpFramebufferState + , dumpFragmentState ) where -import qualified Graphics.Rendering.OpenGL.GL as GL -import Graphics.Rendering.OpenGL (get) - +import qualified Graphics.Rendering.OpenGL.GL as GL +import Graphics.Rendering.OpenGL (get) + -- | Dump internal state of the OpenGL framebuffer dumpFramebufferState :: IO () dumpFramebufferState = do - auxBuffers <- get GL.auxBuffers - doubleBuffer <- get GL.doubleBuffer - drawBuffer <- get GL.drawBuffer + auxBuffers <- get GL.auxBuffers + doubleBuffer <- get GL.doubleBuffer + drawBuffer <- get GL.drawBuffer - rgbaBits <- get GL.rgbaBits - stencilBits <- get GL.stencilBits - depthBits <- get GL.depthBits - accumBits <- get GL.accumBits - - clearColor <- get GL.clearColor - clearStencil <- get GL.clearStencil - clearDepth <- get GL.clearDepth - clearAccum <- get GL.clearAccum - - colorMask <- get GL.colorMask - stencilMask <- get GL.stencilMask - depthMask <- get GL.depthMask - - putStr $ "* dumpFramebufferState\n" - ++ " auxBuffers = " ++ show auxBuffers ++ "\n" - ++ " doubleBuffer = " ++ show doubleBuffer ++ "\n" - ++ " drawBuffer = " ++ show drawBuffer ++ "\n" - ++ "\n" - ++ " bits rgba = " ++ show rgbaBits ++ "\n" - ++ " stencil = " ++ show stencilBits ++ "\n" - ++ " depth = " ++ show depthBits ++ "\n" - ++ " accum = " ++ show accumBits ++ "\n" - ++ "\n" - ++ " clear color = " ++ show clearColor ++ "\n" - ++ " stencil = " ++ show clearStencil ++ "\n" - ++ " depth = " ++ show clearDepth ++ "\n" - ++ " accum = " ++ show clearAccum ++ "\n" - ++ "\n" - ++ " mask color = " ++ show colorMask ++ "\n" - ++ " stencil = " ++ show stencilMask ++ "\n" - ++ " depth = " ++ show depthMask ++ "\n" - ++ "\n" - + rgbaBits <- get GL.rgbaBits + stencilBits <- get GL.stencilBits + depthBits <- get GL.depthBits + accumBits <- get GL.accumBits + + clearColor <- get GL.clearColor + clearStencil <- get GL.clearStencil + clearDepth <- get GL.clearDepth + clearAccum <- get GL.clearAccum + + colorMask <- get GL.colorMask + stencilMask <- get GL.stencilMask + depthMask <- get GL.depthMask + + putStr $ "* dumpFramebufferState\n" + ++ " auxBuffers = " ++ show auxBuffers ++ "\n" + ++ " doubleBuffer = " ++ show doubleBuffer ++ "\n" + ++ " drawBuffer = " ++ show drawBuffer ++ "\n" + ++ "\n" + ++ " bits rgba = " ++ show rgbaBits ++ "\n" + ++ " stencil = " ++ show stencilBits ++ "\n" + ++ " depth = " ++ show depthBits ++ "\n" + ++ " accum = " ++ show accumBits ++ "\n" + ++ "\n" + ++ " clear color = " ++ show clearColor ++ "\n" + ++ " stencil = " ++ show clearStencil ++ "\n" + ++ " depth = " ++ show clearDepth ++ "\n" + ++ " accum = " ++ show clearAccum ++ "\n" + ++ "\n" + ++ " mask color = " ++ show colorMask ++ "\n" + ++ " stencil = " ++ show stencilMask ++ "\n" + ++ " depth = " ++ show depthMask ++ "\n" + ++ "\n" + -- | Dump internal state of the fragment renderer. dumpFragmentState :: IO () dumpFragmentState = do - blend <- get GL.blend - blendEquation <- get GL.blendEquation - blendFunc <- get GL.blendFunc - - putStr $ "* dumpFragmentState\n" - ++ " blend = " ++ show blend ++ "\n" - ++ " blend equation = " ++ show blendEquation ++ "\n" - ++ " blend func = " ++ show blendFunc ++ "\n" - ++ "\n" + blend <- get GL.blend + blendEquation <- get GL.blendEquation + blendFunc <- get GL.blendFunc + + putStr $ "* dumpFragmentState\n" + ++ " blend = " ++ show blend ++ "\n" + ++ " blend equation = " ++ show blendEquation ++ "\n" + ++ " blend func = " ++ show blendFunc ++ "\n" + ++ "\n" diff --git a/Graphics/Gloss/Internals/Interface/Display.hs b/Graphics/Gloss/Internals/Interface/Display.hs --- a/Graphics/Gloss/Internals/Interface/Display.hs +++ b/Graphics/Gloss/Internals/Interface/Display.hs @@ -1,7 +1,7 @@ module Graphics.Gloss.Internals.Interface.Display - (displayWithBackend) -where + (displayWithBackend) +where import Graphics.Gloss.Data.Color import Graphics.Gloss.Data.Picture import Graphics.Gloss.Data.ViewPort @@ -15,27 +15,26 @@ import Graphics.Gloss.Internals.Interface.ViewState.Reshape 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. + :: Backend a + => a -- ^ Initial state of the backend. -> Display -- ^ Display config. - -> Color -- ^ Background color. - -> Picture -- ^ The picture to draw. - -> IO () + -> Color -- ^ Background color. + -> Picture -- ^ The picture to draw. + -> IO () displayWithBackend backend displayMode background picture - = do viewSR <- newIORef viewStateInit + = do viewSR <- newIORef viewStateInit renderS <- initState - renderSR <- newIORef renderS - - let renderFun backendRef = do - port <- viewStateViewPort <$> readIORef viewSR - options <- readIORef renderSR + renderSR <- newIORef renderS + + let renderFun backendRef = do + port <- viewStateViewPort <$> readIORef viewSR + options <- readIORef renderSR windowSize <- getWindowDimensions backendRef displayPicture @@ -48,15 +47,15 @@ -- perform GC every frame to try and avoid long pauses performGC - let callbacks - = [ Callback.Display renderFun + 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 ] + -- Escape exits the program + , callback_exit () + + -- Viewport control with mouse + , callback_viewState_keyMouse viewSR + , callback_viewState_motion viewSR + , callback_viewState_reshape ] - createWindow backend displayMode background callbacks + createWindow backend displayMode background callbacks diff --git a/Graphics/Gloss/Internals/Interface/Event.hs b/Graphics/Gloss/Internals/Interface/Event.hs --- a/Graphics/Gloss/Internals/Interface/Event.hs +++ b/Graphics/Gloss/Internals/Interface/Event.hs @@ -1,53 +1,52 @@ {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.Event ( Event (..) - , keyMouseEvent - , motionEvent ) + , keyMouseEvent + , motionEvent ) where import Data.IORef -import Data.Functor ((<$>)) import Graphics.Gloss.Internals.Interface.Backend -- | Possible input events. data Event - = EventKey Key KeyState Modifiers (Float, Float) - | EventMotion (Float, Float) + = EventKey Key KeyState Modifiers (Float, Float) + | EventMotion (Float, Float) | EventResize (Int, Int) - deriving (Eq, Show) + deriving (Eq, Show) keyMouseEvent :: - forall a . Backend a - => IORef a - -> Key - -> KeyState - -> Modifiers - -> (Int, Int) - -> IO Event + forall a . Backend a + => IORef a + -> Key + -> KeyState + -> Modifiers + -> (Int, Int) + -> IO Event keyMouseEvent backendRef key keyState modifiers pos - = EventKey key keyState modifiers <$> convertPoint backendRef pos + = EventKey key keyState modifiers <$> convertPoint backendRef pos motionEvent :: - forall a . Backend a - => IORef a - -> (Int, Int) - -> IO Event + forall a . Backend a + => IORef a + -> (Int, Int) + -> IO Event motionEvent backendRef pos - = EventMotion <$> convertPoint backendRef pos + = EventMotion <$> convertPoint backendRef pos convertPoint :: - forall a . Backend a - => IORef a - -> (Int, Int) - -> IO (Float,Float) + forall a . Backend a + => IORef a + -> (Int, Int) + -> IO (Float,Float) convertPoint backendRef pos - = do (sizeX_, sizeY_) <- getWindowDimensions backendRef - let (sizeX, sizeY) = (fromIntegral sizeX_, fromIntegral sizeY_) + = do (sizeX_, sizeY_) <- getWindowDimensions backendRef + let (sizeX, sizeY) = (fromIntegral sizeX_, fromIntegral sizeY_) - let (px_, py_) = pos - let px = fromIntegral px_ - let py = sizeY - fromIntegral py_ - - let px' = px - sizeX / 2 - let py' = py - sizeY / 2 - let pos' = (px', py') - return pos' + let (px_, py_) = pos + let px = fromIntegral px_ + let py = sizeY - fromIntegral py_ + + let px' = px - sizeX / 2 + let py' = py - sizeY / 2 + let pos' = (px', py') + return pos' diff --git a/Graphics/Gloss/Internals/Interface/Simulate.hs b/Graphics/Gloss/Internals/Interface/Simulate.hs --- a/Graphics/Gloss/Internals/Interface/Simulate.hs +++ b/Graphics/Gloss/Internals/Interface/Simulate.hs @@ -20,7 +20,6 @@ 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.Functor ((<$>)) import Data.IORef import System.Mem diff --git a/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs b/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs --- a/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs +++ b/Graphics/Gloss/Internals/Interface/Simulate/Idle.hs @@ -2,97 +2,97 @@ {-# 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 - -> (ViewPort -> Float -> world -> IO world) -- ^ fn to advance the world - -> Float -- ^ how much time to advance world by - -- in single step mode - -> IdleCallback - + -> 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 simulate_run simSR animateSR viewSA worldSR worldAdvance backendRef + do simulate_run simSR animateSR viewSA worldSR worldAdvance 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 - + :: 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 + -- 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_ + -- 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_ - 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" + 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 + -- 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) + -- 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) - -- 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' + -- 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' - -- update the control state - simSR `modifyIORef` \c -> c - { SM.stateIteration = nFinal - , SM.stateSimTime = newSimTime } - - -- tell glut we want to draw the window after returning - Backend.postRedisplay backendRef + -- update the control state + simSR `modifyIORef` \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 @@ -104,4 +104,4 @@ where go x | test x = return x | otherwise = op x >>= go - + diff --git a/Graphics/Gloss/Internals/Interface/Simulate/State.hs b/Graphics/Gloss/Internals/Interface/Simulate/State.hs --- a/Graphics/Gloss/Internals/Interface/Simulate/State.hs +++ b/Graphics/Gloss/Internals/Interface/Simulate/State.hs @@ -1,29 +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 - -- | 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 } - + -- | 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 } + -- | Initial control state stateInit :: Int -> State stateInit resolution - = State - { stateIteration = 0 - , stateResolution = resolution - , stateSimTime = 0 } - - + = State + { stateIteration = 0 + , stateResolution = resolution + , stateSimTime = 0 } + + diff --git a/Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs b/Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs --- a/Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs +++ b/Graphics/Gloss/Internals/Interface/ViewState/KeyMouse.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RankNTypes #-} module Graphics.Gloss.Internals.Interface.ViewState.KeyMouse - (callback_viewState_keyMouse) + (callback_viewState_keyMouse) where import Graphics.Gloss.Data.ViewState import Graphics.Gloss.Internals.Interface.Backend @@ -11,22 +11,22 @@ -- | Callback to handle keyboard and mouse button events --- for controlling the 'ViewState'. +-- for controlling the 'ViewState'. callback_viewState_keyMouse - :: IORef ViewState - -> Callback + :: IORef ViewState + -> Callback callback_viewState_keyMouse viewStateRef - = KeyMouse (viewState_keyMouse viewStateRef) + = KeyMouse (viewState_keyMouse viewStateRef) viewState_keyMouse :: IORef ViewState -> KeyboardMouseCallback viewState_keyMouse viewStateRef stateRef key keyState keyMods pos - = do viewState <- readIORef viewStateRef - ev <- keyMouseEvent stateRef key keyState keyMods pos + = do viewState <- readIORef viewStateRef + ev <- keyMouseEvent stateRef key keyState keyMods pos case updateViewStateWithEventMaybe ev viewState of - Nothing -> return () - Just viewState' - -> do viewStateRef `writeIORef` viewState' - postRedisplay stateRef + Nothing -> return () + Just viewState' + -> do viewStateRef `writeIORef` viewState' + postRedisplay stateRef diff --git a/Graphics/Gloss/Internals/Interface/ViewState/Motion.hs b/Graphics/Gloss/Internals/Interface/ViewState/Motion.hs --- a/Graphics/Gloss/Internals/Interface/ViewState/Motion.hs +++ b/Graphics/Gloss/Internals/Interface/ViewState/Motion.hs @@ -2,7 +2,7 @@ {-# 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 +12,23 @@ -- | Callback to handle keyboard and mouse button events --- for controlling the viewport. +-- for controlling the viewport. callback_viewState_motion - :: IORef ViewState - -> Callback + :: IORef ViewState + -> Callback callback_viewState_motion portRef - = Motion (viewState_motion portRef) + = Motion (viewState_motion portRef) viewState_motion :: IORef ViewState -> MotionCallback viewState_motion viewStateRef stateRef pos - = do viewState <- readIORef viewStateRef - ev <- motionEvent stateRef pos + = do viewState <- readIORef viewStateRef + ev <- motionEvent stateRef pos case updateViewStateWithEventMaybe ev viewState of - Nothing -> return () - Just viewState' - -> do viewStateRef `writeIORef` viewState' - postRedisplay stateRef + Nothing -> return () + Just viewState' + -> do viewStateRef `writeIORef` viewState' + postRedisplay stateRef diff --git a/Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs b/Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs --- a/Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs +++ b/Graphics/Gloss/Internals/Interface/ViewState/Reshape.hs @@ -1,28 +1,28 @@ {-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Interface.ViewState.Reshape - (callback_viewState_reshape, viewState_reshape) + (callback_viewState_reshape, viewState_reshape) where import Graphics.Gloss.Internals.Interface.Callback import Graphics.Gloss.Internals.Interface.Backend -import Graphics.Rendering.OpenGL (($=)) -import qualified Graphics.Rendering.OpenGL.GL as GL +import Graphics.Rendering.OpenGL (($=)) +import qualified Graphics.Rendering.OpenGL.GL as GL -- | Callback to handle keyboard and mouse button events --- for controlling the viewport. +-- for controlling the viewport. callback_viewState_reshape :: Callback callback_viewState_reshape - = Reshape (viewState_reshape) + = Reshape (viewState_reshape) viewState_reshape :: ReshapeCallback viewState_reshape stateRef (width,height) = do - -- Setup the viewport - -- This controls what part of the window openGL renders to. - -- We'll use the whole window. - -- - GL.viewport $= ( GL.Position 0 0 + -- Setup the viewport + -- This controls what part of the window openGL renders to. + -- We'll use the whole window. + -- + GL.viewport $= ( GL.Position 0 0 , GL.Size (fromIntegral width) (fromIntegral height)) - postRedisplay stateRef + postRedisplay stateRef diff --git a/Graphics/Gloss/Internals/Interface/Window.hs b/Graphics/Gloss/Internals/Interface/Window.hs --- a/Graphics/Gloss/Internals/Interface/Window.hs +++ b/Graphics/Gloss/Internals/Interface/Window.hs @@ -1,79 +1,79 @@ {-# 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 Graphics.Rendering.OpenGL (($=)) +import qualified Graphics.Rendering.OpenGL.GL as GL import Data.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 + -> IO () createWindow - backend + backend display - clearColor - callbacks + clearColor + callbacks = 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" + when debug + $ do putStr $ "* entering mainloop..\n" - -- Start the main backend loop - runMainLoop backendStateRef + -- Start the main backend loop + runMainLoop backendStateRef - when debug - $ putStr $ "* all done\n" + when debug + $ putStr $ "* all done\n" - return () + return () diff --git a/gloss.cabal b/gloss.cabal --- a/gloss.cabal +++ b/gloss.cabal @@ -1,5 +1,5 @@ Name: gloss -Version: 1.9.2.1 +Version: 1.9.3.1 License: MIT License-file: LICENSE Author: Ben Lippmeier @@ -37,14 +37,14 @@ Library Build-Depends: - base == 4.7.*, - ghc-prim == 0.3.*, + base == 4.8.*, + ghc-prim == 0.4.*, containers == 0.5.*, bytestring == 0.10.*, - OpenGL == 2.9.*, - GLUT == 2.5.*, + OpenGL == 2.12.*, + GLUT == 2.7.*, bmp == 1.2.*, - gloss-rendering == 1.9.2.* + gloss-rendering == 1.9.3.* ghc-options: -O2 -Wall