diff --git a/Graphics/Gloss/Internals/Data/Color.hs b/Graphics/Gloss/Internals/Data/Color.hs --- a/Graphics/Gloss/Internals/Data/Color.hs +++ b/Graphics/Gloss/Internals/Data/Color.hs @@ -112,6 +112,7 @@ clampColor :: Color -> Color clampColor cc = let (r, g, b, a) = rgbaOfColor cc - in RGBA (min 1 r) (min 1 g) (min 1 b) (min 1 a) + clamp x = (min (max x 0.0) 1.0) + in RGBA (clamp r) (clamp g) (clamp b) (clamp a) diff --git a/Graphics/Gloss/Internals/Rendering/Circle.hs b/Graphics/Gloss/Internals/Rendering/Circle.hs --- a/Graphics/Gloss/Internals/Rendering/Circle.hs +++ b/Graphics/Gloss/Internals/Rendering/Circle.hs @@ -12,11 +12,11 @@ import qualified Graphics.Rendering.OpenGL.GL as GL +------------------------------------------------------------------------------- -- | 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. --- circleSteps :: Float -> Int circleSteps sDiam | sDiam < 8 = 8 @@ -81,11 +81,12 @@ -- Arc ------------------------------------------------------------------------ -- | Render an arc with the given thickness. -renderArc :: Float -> Float -> Float -> Float -> Float -> Float -> Float -> IO () +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 - + where + go radius thickness -- Render zero thickness arcs with lines. | thickness == 0 , radScreen <- scaleFactor * radius @@ -99,7 +100,8 @@ -- | Render an arc as a line. -renderArcLine :: Float -> Float -> Int -> Float -> Float -> Float -> IO () +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 @@ -116,13 +118,17 @@ -- | Render an arc with a given thickness as a triangle strip -renderArcStrip :: Float -> Float -> Int -> Float -> Float -> Float -> Float -> IO () +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 = normalizeAngle $ degToRad a1 - t2 = normalizeAngle $ degToRad a2 + + a2' = normalizeAngle $ degToRad a2 + t2 = if a2' == 0 then 2*pi else a2' + (tStart, tStop) = if t1 <= t2 then (t1, t2) else (t2, t1) tDiff = tStop - tStart tMid = tStart + tDiff / 2 @@ -137,24 +143,23 @@ !(F# r2') = r + width / 2 in GL.renderPrimitive GL.TriangleStrip - $ do - -- start vector - addPointOnCircle posX posY r1' tStart' - addPointOnCircle posX posY r2' tStart' + $ 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 + -- 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' + else do + renderCircleStrip_step posX posY + tStep' tCut' r1' tStart' r2' (tStart' `plusFloat#` tStep2') -- end vectors @@ -214,17 +219,17 @@ -- | Convert degrees to radians -{-# INLINE degToRad #-} degToRad :: Float -> Float degToRad d = d * pi / 180 +{-# INLINE degToRad #-} -- | Normalise an angle to be between 0 and 2*pi radians -{-# INLINE normalizeAngle #-} normalizeAngle :: Float -> Float normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi)) where floor' :: Float -> Float floor' x = fromIntegral (floor x :: Int) +{-# INLINE normalizeAngle #-} {- Unused sector drawing code. diff --git a/Graphics/Gloss/Internals/Rendering/Picture.hs b/Graphics/Gloss/Internals/Rendering/Picture.hs --- a/Graphics/Gloss/Internals/Rendering/Picture.hs +++ b/Graphics/Gloss/Internals/Rendering/Picture.hs @@ -58,7 +58,6 @@ -> GL.renderPrimitive GL.LineStrip $ vertexPFs path - -- polygon (where?) Polygon path | stateWireframe state @@ -132,7 +131,6 @@ $ do GL.translate (GL.Vector3 (gf tx) (gf ty) 0) drawPicture state circScale p - -- Rotation ----------------------------- -- Easy rotations are done directly to avoid calling GL.perserveMatrix. Rotate _ (Circle radius) @@ -153,7 +151,6 @@ $ do GL.rotate (gf deg) (GL.Vector3 0 0 (-1)) drawPicture state circScale p - -- Scale -------------------------------- Scale sx sy p -> GL.preservingMatrix @@ -175,8 +172,7 @@ { bitmapSize = (width, height) , bitmapCacheMe = cacheMe } -> - -- width height imgData cacheMe imgSectionPos imgSectionSize -> - do + do let rowInfo = -- calculate texture coordinates -- remark: @@ -228,14 +224,15 @@ -- Set to opaque oldColor <- get GL.currentColor GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0 - + -- Draw textured polygon GL.renderPrimitive GL.Polygon $ - forM_ (bitmapPath (fromIntegral $ fst imgSectionSize) (fromIntegral $ snd imgSectionSize) `zip` rowInfo) $ + forM_ (bitmapPath (fromIntegral $ fst imgSectionSize) + (fromIntegral $ snd imgSectionSize) `zip` rowInfo) $ \((polygonCoordX, polygonCoordY), (textureCoordX,textureCoordY)) -> do GL.texCoord $ GL.TexCoord2 (gf textureCoordX) (gf textureCoordY) - GL.vertex $ GL.Vertex2 (gf polygonCoordX) (gf polygonCoordY) + GL.vertex $ GL.Vertex2 (gf polygonCoordX) (gf polygonCoordY) -- Restore color GL.currentColor $= oldColor @@ -289,13 +286,12 @@ -- Textures ------------------------------------------------------------------- --- | Load a texture. --- If we've seen it before then use the pre-installed one from the texture --- cache, otherwise load it into OpenGL. +-- | Load a texture into the OpenGL context, or retrieve the existing handle +-- from our own cache. loadTexture - :: IORef [Texture] - -> BitmapData - -> Bool + :: IORef [Texture] -- ^ Existing texture cache. + -> BitmapData -- ^ Texture data. + -> Bool -- ^ Force cache for newly loaded textures. -> IO Texture loadTexture refTextures imgData@BitmapData{ bitmapSize=(width,height) } cacheMe @@ -314,17 +310,15 @@ -> return tex Nothing - -> do tex <- installTexture imgData + -> do tex <- installTexture imgData when cacheMe $ writeIORef refTextures (tex : textures) return tex --- | Install a texture into OpenGL. -installTexture - :: BitmapData - -> IO Texture - +-- | Install a texture into the OpenGL context, +-- returning the new texture handle. +installTexture :: BitmapData -> IO Texture installTexture bitmapData@(BitmapData _ fmt (width,height) cacheMe fptr) = do let glFormat @@ -374,7 +368,6 @@ | otherwise = GL.deleteObjectNames [texObject tex] - -- Utils ---------------------------------------------------------------------- -- | Turn alpha blending on or off setBlendAlpha :: Bool -> IO () @@ -386,6 +379,7 @@ | otherwise = do GL.blend $= GL.Disabled GL.blendFunc $= (GL.One, GL.Zero) + -- | Turn line smoothing on or off setLineSmooth :: Bool -> IO () diff --git a/gloss-rendering.cabal b/gloss-rendering.cabal --- a/gloss-rendering.cabal +++ b/gloss-rendering.cabal @@ -1,5 +1,5 @@ name: gloss-rendering -version: 1.13.0.2 +version: 1.13.1.1 license: MIT license-file: LICENSE author: Elise Huard @@ -37,10 +37,10 @@ Graphics.Gloss.Internals.Rendering.State build-depends: - base >= 4.8 && < 4.12 + base >= 4.8 && < 4.13 , bmp == 1.2.* , bytestring == 0.10.* - , containers == 0.5.* + , containers >= 0.5 && < 0.7 , GLUT == 2.7.* , OpenGL >= 2.12 && < 3.1