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 @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK hide #-} -- | Data type for representing colors. @@ -42,7 +43,7 @@ signum (RGBA r1 g1 b1 _) = RGBA (signum r1) (signum g1) (signum b1) 1 {-# INLINE signum #-} - + fromInteger i = let f = fromInteger i in RGBA f f f 1 @@ -50,7 +51,7 @@ -- | Make a custom color. All components are clamped to the range [0..1]. -makeColor +makeColor :: Float -- ^ Red component. -> Float -- ^ Green component. -> Float -- ^ Blue component. @@ -58,7 +59,7 @@ -> Color makeColor r g b a - = clampColor + = clampColor $ RGBA r g b a {-# INLINE makeColor #-} @@ -66,20 +67,20 @@ -- | Make a custom color. All components are clamped to the range [0..255]. makeColorI :: Int -> Int -> Int -> Int -> Color makeColorI r g b a - = clampColor - $ RGBA (fromIntegral r / 255) + = clampColor + $ RGBA (fromIntegral r / 255) (fromIntegral g / 255) (fromIntegral b / 255) (fromIntegral a / 255) {-# INLINE makeColorI #-} --- | Make a custom color. +-- | Make a custom color. -- -- Using this function over `makeColor` avoids clamping the components, -- which saves time. However, if the components are out of range then -- this will result in integer overflow at rendering time, and the actual --- picture you get will be implementation dependent. +-- picture you get will be implementation dependent. -- -- You'll only need to use this function when using the @gloss-raster@ -- package that builds a new color for every pixel. If you're just working @@ -94,7 +95,7 @@ -- | Make a custom color, taking pre-clamped components. makeRawColorI :: Int -> Int -> Int -> Int -> Color makeRawColorI r g b a - = RGBA (fromIntegral r / 255) + = RGBA (fromIntegral r / 255) (fromIntegral g / 255) (fromIntegral b / 255) (fromIntegral a / 255) @@ -105,7 +106,7 @@ rgbaOfColor :: Color -> (Float, Float, Float, Float) rgbaOfColor (RGBA r g b a) = (r, g, b, a) {-# INLINE rgbaOfColor #-} - + -- | Clamp components of a raw color into the required range. clampColor :: Color -> Color diff --git a/Graphics/Gloss/Internals/Data/Picture.hs b/Graphics/Gloss/Internals/Data/Picture.hs --- a/Graphics/Gloss/Internals/Data/Picture.hs +++ b/Graphics/Gloss/Internals/Data/Picture.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK hide #-} -{-# OPTIONS -fno-warn-orphans #-} -- | Data types for representing pictures. module Graphics.Gloss.Internals.Data.Picture @@ -30,25 +31,13 @@ import qualified Data.ByteString.Unsafe as BSU import Prelude hiding (map) +#if __GLASGOW_HASKELL__ >= 800 +import Data.Semigroup +import Data.List.NonEmpty +#endif -- | A point on the x-y plane. -type Point = (Float, Float) - - --- | Pretend a point is a number. --- Vectors aren't real numbers according to Haskell, because they don't --- support the multiply and divide field operators. We can pretend they --- are though, and use the (+) and (-) operators as component-wise --- addition and subtraction. --- -instance Num Point where - (+) (x1, y1) (x2, y2) = (x1 + x2, y1 + y2) - (-) (x1, y1) (x2, y2) = (x1 - x2, y1 - y2) - (*) (x1, y1) (x2, y2) = (x1 * x2, y1 * y2) - signum (x, y) = (signum x, signum y) - abs (x, y) = (abs x, abs y) - negate (x, y) = (negate x, negate y) - fromInteger x = (fromInteger x, fromInteger x) +type Point = (Float, Float) -- | A vector can be treated as a point, and vis-versa. @@ -56,7 +45,7 @@ -- | A path through the x-y plane. -type Path = [Point] +type Path = [Point] -- | A 2D picture @@ -68,7 +57,7 @@ -- | A convex polygon filled with a solid color. | Polygon Path - + -- | A line along an arbitrary path. | Line Path @@ -79,11 +68,11 @@ -- If the thickness is 0 then this is equivalent to `Circle`. | ThickCircle Float Float - -- | A circular arc drawn counter-clockwise between two angles + -- | 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 + -- | 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 @@ -97,7 +86,7 @@ -- The boolean flag controls whether Gloss should cache the data -- in GPU memory between frames. If you are programatically generating -- the image for each frame then use @False@. If you have loaded it - -- from a file then use @True@. + -- from a file then use @True@. -- Setting @False@ for static images will make rendering slower -- than it needs to be. -- Setting @True@ for dynamically generated images will cause a @@ -126,9 +115,16 @@ -- Instances ------------------------------------------------------------------ instance Monoid Picture where - mempty = Blank - mappend a b = Pictures [a, b] - mconcat = Pictures + mempty = Blank + mappend a b = Pictures [a, b] + mconcat = Pictures + +#if __GLASGOW_HASKELL__ >= 800 +instance Semigroup Picture where + a <> b = Pictures [a, b] + sconcat = Pictures . toList + stimes = stimesIdempotent +#endif -- Bitmaps -------------------------------------------------------------------- diff --git a/Graphics/Gloss/Internals/Rendering/Bitmap.hs b/Graphics/Gloss/Internals/Rendering/Bitmap.hs --- a/Graphics/Gloss/Internals/Rendering/Bitmap.hs +++ b/Graphics/Gloss/Internals/Rendering/Bitmap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK hide #-} -- | Helper functions for rendering bitmaps @@ -16,7 +17,7 @@ = BitmapData { bitmapDataLength :: Int -- length (in bytes) , bitmapFormat :: BitmapFormat - , bitmapPointer :: (ForeignPtr Word8) } + , bitmapPointer :: (ForeignPtr Word8) } deriving (Eq, Data, Typeable) @@ -25,7 +26,7 @@ -- * Prior version of Gloss assumed `BitmapFormat BottomToTop PxAGBR` -- data BitmapFormat - = BitmapFormat + = BitmapFormat { rowOrder :: RowOrder , pixelFormat :: PixelFormat } deriving (Eq, Data, Typeable, Show, Ord) @@ -37,7 +38,7 @@ -- * `BottomToTop` - the bottom row followed by the next-higher row and so on. -- data RowOrder - = TopToBottom + = TopToBottom | BottomToTop deriving (Eq, Data, Typeable, Show, Ord, Enum, Bounded) 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} {-# OPTIONS_HADDOCK hide #-} -- | Fast(ish) rendering of circles. @@ -11,7 +13,7 @@ -- | 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 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. -- @@ -72,7 +74,7 @@ !(F# r2) = r + width / 2 in GL.renderPrimitive GL.TriangleStrip - $ renderCircleStrip_step posX posY tStep tStop r1 0.0# r2 + $ renderCircleStrip_step posX posY tStep tStop r1 0.0# r2 (tStep `divideFloat#` 2.0#) {-# INLINE renderCircleStrip #-} @@ -94,8 +96,8 @@ | 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 @@ -133,9 +135,9 @@ !(F# tMid') = tMid !(F# r1') = r - width / 2 !(F# r2') = r + width / 2 - + in GL.renderPrimitive GL.TriangleStrip - $ do + $ do -- start vector addPointOnCircle posX posY r1' tStart' addPointOnCircle posX posY r2' tStart' @@ -165,34 +167,34 @@ renderCircleLine_step :: Float# -> Float# -> Float# -> Float# - -> Float# -> Float# + -> Float# -> Float# -> IO () renderCircleLine_step posX posY tStep tStop rad tt | 1# <- tt `geFloat#` tStop = return () - + | otherwise = do addPointOnCircle posX posY rad tt - renderCircleLine_step posX posY tStep tStop rad + renderCircleLine_step posX posY tStep tStop rad (tt `plusFloat#` tStep) {-# INLINE renderCircleLine_step #-} -renderCircleStrip_step - :: Float# -> Float# - -> Float# -> Float# +renderCircleStrip_step + :: Float# -> Float# -> Float# -> Float# + -> Float# -> Float# -> Float# -> Float# -> IO () renderCircleStrip_step posX posY tStep tStop r1 t1 r2 t2 | 1# <- t1 `geFloat#` tStop = return () - + | otherwise = do addPointOnCircle posX posY r1 t1 addPointOnCircle posX posY r2 t2 - renderCircleStrip_step posX posY tStep tStop r1 + renderCircleStrip_step posX posY tStep tStop r1 (t1 `plusFloat#` tStep) r2 (t2 `plusFloat#` tStep) {-# INLINE renderCircleStrip_step #-} @@ -227,7 +229,7 @@ {- Unused sector drawing code. Sectors are currently drawn as compound Pictures, - but we might want this if we end up implementing the ThickSector + but we might want this if we end up implementing the ThickSector version as well. -- | Render a sector as a line. diff --git a/Graphics/Gloss/Internals/Rendering/Common.hs b/Graphics/Gloss/Internals/Rendering/Common.hs --- a/Graphics/Gloss/Internals/Rendering/Common.hs +++ b/Graphics/Gloss/Internals/Rendering/Common.hs @@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} -module Graphics.Gloss.Internals.Rendering.Common +module Graphics.Gloss.Internals.Rendering.Common ( gf, gsizei , withModelview , withClearBuffer) @@ -14,7 +14,7 @@ -- | The OpenGL library doesn't seem to provide a nice way convert -- a Float to a GLfloat, even though they're the same thing --- under the covers. +-- under the covers. -- -- Using realToFrac is too slow, as it doesn't get fused in at -- least GHC 6.12.1 @@ -46,25 +46,25 @@ GL.loadIdentity let (sx, sy) = (fromIntegral sizeX / 2, fromIntegral sizeY / 2) GL.ortho (-sx) sx (-sy) sy 0 (-100) - + -- draw the world GL.matrixMode $= GL.Modelview 0 action GL.matrixMode $= GL.Projection - + GL.matrixMode $= GL.Modelview 0 --- | Clear the OpenGL buffer with the given background color and run +-- | Clear the OpenGL buffer with the given background color and run -- an action to draw the model. -withClearBuffer +withClearBuffer :: Color -- ^ Background color -> IO () -- ^ Action to perform -> IO () withClearBuffer clearColor action - = do + = do -- initialization (done every time in this case) -- we don't need the depth buffer for 2d. GL.depthFunc GL.$= Just GL.Always 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Rendering.Picture @@ -32,18 +33,18 @@ -> IO () renderPicture state circScale picture - = do + = do -- Setup render state for world setLineSmooth (stateLineSmooth state) setBlendAlpha (stateBlendAlpha state) - + -- Draw the picture checkErrors "before drawPicture." drawPicture state circScale picture checkErrors "after drawPicture." -drawPicture :: State -> Float -> Picture -> IO () +drawPicture :: State -> Float -> Picture -> IO () drawPicture state circScale picture = {-# SCC "drawComponent" #-} case picture of @@ -53,8 +54,8 @@ -> return () -- line - Line path - -> GL.renderPrimitive GL.LineStrip + Line path + -> GL.renderPrimitive GL.LineStrip $ vertexPFs path @@ -63,7 +64,7 @@ | stateWireframe state -> GL.renderPrimitive GL.LineLoop $ vertexPFs path - + | otherwise -> GL.renderPrimitive GL.Polygon $ vertexPFs path @@ -71,21 +72,21 @@ -- circle Circle radius -> renderCircle 0 0 circScale radius 0 - + ThickCircle radius thickness -> renderCircle 0 0 circScale radius thickness - + -- arc Arc a1 a2 radius -> renderArc 0 0 circScale radius a1 a2 0 - + ThickArc a1 a2 radius thickness -> renderArc 0 0 circScale radius a1 a2 thickness - + -- stroke text -- text looks weird when we've got blend on, -- so disable it during the renderString call. - Text str + Text str -> do GL.blend $= GL.Disabled GL.preservingMatrix $ GLUT.renderString GLUT.Roman str @@ -100,7 +101,7 @@ GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a) drawPicture state circScale p - GL.currentColor $= oldColor + GL.currentColor $= oldColor | otherwise -> drawPicture state circScale p @@ -119,7 +120,7 @@ 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) @@ -146,7 +147,7 @@ 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)) @@ -159,10 +160,10 @@ $ do GL.scale (gf sx) (gf sy) 1 let mscale = max sx sy drawPicture state (circScale * mscale) p - + -- Bitmap ------------------------------- Bitmap width height imgData cacheMe - -> do + -> do let rowInfo = case rowOrder (bitmapFormat imgData) of BottomToTop -> [(0,0), (1,0), (1,1), (0,1)] @@ -171,23 +172,23 @@ -- Load the image data into a texture, -- or grab it from the cache if we've already done that before. tex <- loadTexture (stateTextures state) width height imgData cacheMe - + -- Set up wrap and filtering mode GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat) GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat) GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest) - + -- Enable texturing GL.texture GL.Texture2D $= GL.Enabled GL.textureFunction $= GL.Combine - + -- Set current texture GL.textureBinding GL.Texture2D $= Just (texObject tex) - + -- Set to opaque oldColor <- get GL.currentColor GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0 - + -- Draw textured polygon GL.renderPrimitive GL.Polygon $ zipWithM_ @@ -206,11 +207,11 @@ -- Free uncachable texture objects. freeTexture tex - + Pictures ps -> mapM_ (drawPicture state circScale) ps - + -- Errors --------------------------------------------------------------------- checkErrors :: String -> IO () checkErrors place @@ -222,7 +223,7 @@ handleError place err = case err of GLU.Error GLU.StackOverflow _ - -> error $ unlines + -> error $ unlines [ "Gloss / OpenGL Stack Overflow " ++ show place , " This program uses the Gloss vector graphics library, which tried to" , " draw a picture using more nested transforms (Translate/Rotate/Scale)" @@ -238,13 +239,13 @@ , " transforms used when defining the Picture given to Gloss. Sorry." ] -- Issue #32: Spurious "Invalid Operation" errors under Windows 7 64-bit. - -- When using GLUT under Windows 7 it complains about InvalidOperation, - -- but doesn't provide any other details. All the examples look ok, so + -- When using GLUT under Windows 7 it complains about InvalidOperation, + -- but doesn't provide any other details. All the examples look ok, so -- we're just ignoring the error for now. GLU.Error GLU.InvalidOperation _ -> return () - _ - -> error $ unlines + _ + -> error $ unlines [ "Gloss / OpenGL Internal Error " ++ show place , " Please report this on haskell-gloss@googlegroups.com." , show err ] @@ -265,16 +266,16 @@ -- Try and find this same texture in the cache. name <- makeStableName imgData - let mTexCached + let mTexCached = find (\tex -> texName tex == name && texWidth tex == width && texHeight tex == height) textures - + case mTexCached of Just tex -> return tex - + Nothing -> do tex <- installTexture width height imgData cacheMe when cacheMe @@ -283,15 +284,15 @@ -- | Install a texture into OpenGL. -installTexture +installTexture :: Int -> Int -> BitmapData -> Bool -> IO Texture installTexture width height bitmapData@(BitmapData _ fmt fptr) cacheMe - = do - let glFormat + = do + let glFormat = case pixelFormat fmt of PxABGR -> GL.ABGR PxRGBA -> GL.RGBA @@ -301,7 +302,7 @@ GL.textureBinding GL.Texture2D $= Just tex -- Sets the texture in imgData as the current texture - -- This copies the data from the pointer into OpenGL texture memory, + -- This copies the data from the pointer into OpenGL texture memory, -- so it's ok if the foreignptr gets garbage collected after this. withForeignPtr fptr $ \ptr -> @@ -330,7 +331,7 @@ , texCacheMe = cacheMe } --- | If this texture does not have its `cacheMe` flag set then delete it from +-- | If this texture does not have its `cacheMe` flag set then delete it from -- OpenGL and free the GPU memory. freeTexture :: Texture -> IO () freeTexture tex @@ -343,13 +344,13 @@ -- | Turn alpha blending on or off setBlendAlpha :: Bool -> IO () setBlendAlpha state - | state + | state = do GL.blend $= GL.Enabled GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) | otherwise = do GL.blend $= GL.Disabled - GL.blendFunc $= (GL.One, GL.Zero) + GL.blendFunc $= (GL.One, GL.Zero) -- | Turn line smoothing on or off setLineSmooth :: Bool -> IO () diff --git a/Graphics/Gloss/Rendering.hs b/Graphics/Gloss/Rendering.hs --- a/Graphics/Gloss/Rendering.hs +++ b/Graphics/Gloss/Rendering.hs @@ -1,5 +1,5 @@ -module Graphics.Gloss.Rendering +module Graphics.Gloss.Rendering ( -- * Picture data type Picture (..) , Point, Vector, Path @@ -38,11 +38,11 @@ -- | Set up the OpenGL context, clear the buffer, and render the given picture --- into it. +-- into it. -- -- This is the same as `renderPicture` composed with `withModelview` -- and `withClearBuffer`. If you want to manage your own OpenGL context then --- you can just call `renderPicture`. +-- you can just call `renderPicture`. -- -- Using this function assumes that you've already opened a window -- and set that to the active context. If you don't want to do your own window @@ -60,3 +60,4 @@ = withModelview windowSize $ withClearBuffer colorClear $ renderPicture state scale picture + 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.11.1.1 +version: 1.12.0.0 license: MIT license-file: LICENSE author: Elise Huard @@ -7,17 +7,26 @@ category: Graphics build-type: Simple cabal-version: >=1.10 -synopsis: Gloss picture data types and rendering functions. -description: +synopsis: Gloss picture data types and rendering functions. +description: Gloss picture data types and rendering functions. These functions don't do any window management. If you want gloss to setup your window as well then use the plain @gloss@ package. +source-repository head + type: git + location: https://github.com/benl23x5/gloss + +source-repository this + type: git + tag: v1.12.0.0 + location: https://github.com/benl23x5/gloss + library exposed-modules: Graphics.Gloss.Rendering - other-modules: + other-modules: Graphics.Gloss.Internals.Data.Color Graphics.Gloss.Internals.Data.Picture Graphics.Gloss.Internals.Rendering.Bitmap @@ -27,23 +36,18 @@ Graphics.Gloss.Internals.Rendering.Picture Graphics.Gloss.Internals.Rendering.State - build-depends: - base >= 4.8 && < 4.10, - containers == 0.5.*, - bytestring == 0.10.*, - OpenGL >= 2.12 && < 3.1, - GLUT == 2.7.*, - bmp == 1.2.* + build-depends: + base >= 4.8 && < 4.12 + , bmp == 1.2.* + , bytestring == 0.10.* + , containers == 0.5.* + , GLUT == 2.7.* + , OpenGL >= 2.12 && < 3.1 ghc-options: -Wall -O2 - default-language: + default-language: Haskell2010 - default-extensions: - BangPatterns - MagicHash - TypeSynonymInstances - FlexibleInstances - DeriveDataTypeable +-- vim: nospell