gloss-rendering-1.10.3.3/0000755000000000000000000000000012746253753013243 5ustar0000000000000000gloss-rendering-1.10.3.3/gloss-rendering.cabal0000644000000000000000000000267012746253753017336 0ustar0000000000000000name: gloss-rendering version: 1.10.3.3 license: MIT license-file: LICENSE author: Elise Huard maintainer: elise@jabberwocky.eu benl@ouroborus.net category: Graphics build-type: Simple cabal-version: >=1.10 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. library exposed-modules: Graphics.Gloss.Rendering other-modules: Graphics.Gloss.Internals.Data.Color Graphics.Gloss.Internals.Data.Picture Graphics.Gloss.Internals.Rendering.Bitmap Graphics.Gloss.Internals.Rendering.Circle Graphics.Gloss.Internals.Rendering.Color Graphics.Gloss.Internals.Rendering.Common 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.* ghc-options: -Wall -O2 default-language: Haskell2010 default-extensions: BangPatterns MagicHash TypeSynonymInstances FlexibleInstances DeriveDataTypeable gloss-rendering-1.10.3.3/LICENSE0000644000000000000000000000115612746253753014253 0ustar0000000000000000Copyright (c) 2010-2016 The Gloss Development Team Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following condition: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. gloss-rendering-1.10.3.3/Setup.hs0000644000000000000000000000005612746253753014700 0ustar0000000000000000import Distribution.Simple main = defaultMain gloss-rendering-1.10.3.3/Graphics/0000755000000000000000000000000012746253753015003 5ustar0000000000000000gloss-rendering-1.10.3.3/Graphics/Gloss/0000755000000000000000000000000012746253753016072 5ustar0000000000000000gloss-rendering-1.10.3.3/Graphics/Gloss/Rendering.hs0000644000000000000000000000365012746253753020347 0ustar0000000000000000 module Graphics.Gloss.Rendering ( -- * Picture data type Picture (..) , Point, Vector, Path -- * Colors , Color , makeColor , makeColorI , makeRawColor , makeRawColorI , rgbaOfColor , clampColor -- * Bitmaps , BitmapData , BitmapFormat(..), PixelFormat(..), RowOrder(..) , bitmapOfForeignPtr , bitmapOfByteString , bitmapOfBMP , loadBMP -- * Rendering , displayPicture , renderPicture , withModelview , withClearBuffer , RS.initState , RS.State) where import Graphics.Gloss.Internals.Rendering.Common import Graphics.Gloss.Internals.Rendering.Picture import Graphics.Gloss.Internals.Data.Picture import Graphics.Gloss.Internals.Data.Color import qualified Graphics.Gloss.Internals.Rendering.State as RS -- | Set up the OpenGL context, clear the buffer, and render the given picture -- 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`. -- -- 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 -- management then use the @gloss@ package instead. displayPicture :: (Int, Int) -- ^ Window width and height. -> Color -- ^ Color to clear the window with. -> RS.State -- ^ Current rendering state. -> Float -- ^ View port scale, which controls the level of detail. -- Use 1.0 to start with. -> Picture -- ^ Picture to draw. -> IO () displayPicture windowSize colorClear state scale picture = withModelview windowSize $ withClearBuffer colorClear $ renderPicture state scale picture gloss-rendering-1.10.3.3/Graphics/Gloss/Internals/0000755000000000000000000000000012746253753020031 5ustar0000000000000000gloss-rendering-1.10.3.3/Graphics/Gloss/Internals/Data/0000755000000000000000000000000012746253753020702 5ustar0000000000000000gloss-rendering-1.10.3.3/Graphics/Gloss/Internals/Data/Color.hs0000644000000000000000000000647612746253753022331 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | Data type for representing colors. module Graphics.Gloss.Internals.Data.Color ( Color (..) , makeColor , makeColorI , makeRawColor , makeRawColorI , rgbaOfColor , clampColor) where import Data.Data -- | An abstract color value. -- We keep the type abstract so we can be sure that the components -- are in the required range. To make a custom color use 'makeColor'. data Color -- | Holds the color components. All components lie in the range [0..1. = RGBA !Float !Float !Float !Float deriving (Show, Eq, Data, Typeable) instance Num Color where (+) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) = RGBA (r1 + r2) (g1 + g2) (b1 + b2) 1 {-# INLINE (+) #-} (-) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) = RGBA (r1 - r2) (g1 - g2) (b1 - b2) 1 {-# INLINE (-) #-} (*) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) = RGBA (r1 * r2) (g1 * g2) (b1 * b2) 1 {-# INLINE (*) #-} abs (RGBA r1 g1 b1 _) = RGBA (abs r1) (abs g1) (abs b1) 1 {-# INLINE abs #-} 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 {-# INLINE fromInteger #-} -- | Make a custom color. All components are clamped to the range [0..1]. makeColor :: Float -- ^ Red component. -> Float -- ^ Green component. -> Float -- ^ Blue component. -> Float -- ^ Alpha component. -> Color makeColor r g b a = clampColor $ RGBA r g b a {-# INLINE makeColor #-} -- | Make a custom color. 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) (fromIntegral g / 255) (fromIntegral b / 255) (fromIntegral a / 255) {-# INLINE makeColorI #-} -- | 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. -- -- 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 -- with the Picture data type then it there is no need for raw colors. -- makeRawColor :: Float -> Float -> Float -> Float -> Color makeRawColor r g b a = RGBA r g b a {-# INLINE makeRawColor #-} -- | Make a custom color, taking pre-clamped components. makeRawColorI :: Int -> Int -> Int -> Int -> Color makeRawColorI r g b a = RGBA (fromIntegral r / 255) (fromIntegral g / 255) (fromIntegral b / 255) (fromIntegral a / 255) {-# INLINE makeRawColorI #-} -- | Take the RGBA components of a color. rgbaOfColor :: Color -> (Float, Float, Float, Float) rgbaOfColor (RGBA r g b a) = (r, g, b, a) {-# INLINE rgbaOfColor #-} -- | Clamp components of a raw color into the required range. clampColor :: Color -> Color clampColor cc = let (r, g, b, a) = rgbaOfColor cc in RGBA (min 1 r) (min 1 g) (min 1 b) (min 1 a) gloss-rendering-1.10.3.3/Graphics/Gloss/Internals/Data/Picture.hs0000644000000000000000000001531612746253753022657 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS -fno-warn-orphans #-} -- | Data types for representing pictures. module Graphics.Gloss.Internals.Data.Picture ( Point , Vector , Path , Picture(..) -- * Bitmaps , BitmapData, PixelFormat(..), BitmapFormat(..), RowOrder(..) , bitmapOfForeignPtr , bitmapOfByteString , bitmapOfBMP , loadBMP) where import Graphics.Gloss.Internals.Data.Color import Graphics.Gloss.Internals.Rendering.Bitmap import Codec.BMP import Foreign.ForeignPtr import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Data.Word import Data.Monoid import Data.ByteString import Data.Data import System.IO.Unsafe import qualified Data.ByteString.Unsafe as BSU import Prelude hiding (map) -- | A 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) -- | A vector can be treated as a point, and vis-versa. type Vector = Point -- | A path through the x-y plane. type Path = [Point] -- | A 2D picture data Picture -- Primitives ------------------------------------- -- | A blank picture, with nothing in it. = Blank -- | A convex polygon filled with a solid color. | Polygon Path -- | A line along an arbitrary path. | Line Path -- | A circle with the given radius. | Circle Float -- | A circle with the given thickness and radius. -- If the thickness is 0 then this is equivalent to `Circle`. | ThickCircle Float Float -- | A circular arc drawn counter-clockwise between two angles -- (in degrees) at the given radius. | Arc Float Float Float -- | A circular arc drawn counter-clockwise between two angles -- (in degrees), with the given radius and thickness. -- If the thickness is 0 then this is equivalent to `Arc`. | ThickArc Float Float Float Float -- | Some text to draw with a vector font. | Text String -- | A bitmap image with a width, height and some 32-bit RGBA -- bitmap data. -- -- The boolean flag controls whether Gloss should cache the data -- 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@. -- Setting @False@ for static images will make rendering slower -- than it needs to be. -- Setting @True@ for dynamically generated images will cause a -- GPU memory leak. | Bitmap Int Int BitmapData Bool -- Color ------------------------------------------ -- | A picture drawn with this color. | Color Color Picture -- Transforms ------------------------------------- -- | A picture translated by the given x and y coordinates. | Translate Float Float Picture -- | A picture rotated clockwise by the given angle (in degrees). | Rotate Float Picture -- | A picture scaled by the given x and y factors. | Scale Float Float Picture -- More Pictures ---------------------------------- -- | A picture consisting of several others. | Pictures [Picture] deriving (Show, Eq, Data, Typeable) -- Instances ------------------------------------------------------------------ instance Monoid Picture where mempty = Blank mappend a b = Pictures [a, b] mconcat = Pictures -- Bitmaps -------------------------------------------------------------------- -- | O(1). Use a `ForeignPtr` of RGBA data as a bitmap with the given -- width and height. -- -- The boolean flag controls whether Gloss should cache the data -- between frames for speed. If you are programatically generating -- the image for each frame then use `False`. If you have loaded it -- from a file then use `True`. bitmapOfForeignPtr :: Int -> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> Picture bitmapOfForeignPtr width height fmt fptr cacheMe = let len = width * height * 4 bdata = BitmapData len fmt fptr in Bitmap width height bdata cacheMe -- | O(size). Copy a `ByteString` of RGBA data into a bitmap with the given -- width and height. -- -- The boolean flag controls whether Gloss should cache the data -- between frames for speed. If you are programatically generating -- the image for each frame then use `False`. If you have loaded it -- from a file then use `True`. bitmapOfByteString :: Int -> Int -> BitmapFormat -> ByteString -> Bool -> Picture bitmapOfByteString width height fmt bs cacheMe = unsafePerformIO $ do let len = width * height * 4 ptr <- mallocBytes len fptr <- newForeignPtr finalizerFree ptr BSU.unsafeUseAsCString bs $ \cstr -> copyBytes ptr (castPtr cstr) len let bdata = BitmapData len fmt fptr return $ Bitmap width height bdata cacheMe {-# NOINLINE bitmapOfByteString #-} -- | O(size). Copy a `BMP` file into a bitmap. bitmapOfBMP :: BMP -> Picture bitmapOfBMP bmp = unsafePerformIO $ do let (width, height) = bmpDimensions bmp let bs = unpackBMPToRGBA32 bmp let len = width * height * 4 ptr <- mallocBytes len fptr <- newForeignPtr finalizerFree ptr BSU.unsafeUseAsCString bs $ \cstr -> copyBytes ptr (castPtr cstr) len let bdata = BitmapData len (BitmapFormat BottomToTop PxABGR) fptr return $ Bitmap width height bdata True {-# NOINLINE bitmapOfBMP #-} -- | Load an uncompressed 24 or 32bit RGBA BMP file as a bitmap. loadBMP :: FilePath -> IO Picture loadBMP filePath = do ebmp <- readBMP filePath case ebmp of Left err -> error $ show err Right bmp -> return $ bitmapOfBMP bmp gloss-rendering-1.10.3.3/Graphics/Gloss/Internals/Rendering/0000755000000000000000000000000012746253753021746 5ustar0000000000000000gloss-rendering-1.10.3.3/Graphics/Gloss/Internals/Rendering/Bitmap.hs0000644000000000000000000000352112746253753023517 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | Helper functions for rendering bitmaps module Graphics.Gloss.Internals.Rendering.Bitmap ( BitmapData(..) , BitmapFormat(..), PixelFormat(..), RowOrder(..) , bitmapPath , freeBitmapData) where import Data.Data import Foreign -- | Abstract 32-bit RGBA bitmap data. data BitmapData = BitmapData { bitmapDataLength :: Int -- length (in bytes) , bitmapFormat :: BitmapFormat , bitmapPointer :: (ForeignPtr Word8) } deriving (Eq, Data, Typeable) -- | Description of how the bitmap is layed out in memory. -- -- * Prior version of Gloss assumed `BitmapFormat BottomToTop PxAGBR` -- data BitmapFormat = BitmapFormat { rowOrder :: RowOrder , pixelFormat :: PixelFormat } deriving (Eq, Data, Typeable, Show, Ord) -- | Order of rows in an image are either: -- -- * `TopToBottom` - the top row, followed by the next-lower row and so on. -- * `BottomToTop` - the bottom row followed by the next-higher row and so on. -- data RowOrder = TopToBottom | BottomToTop deriving (Eq, Data, Typeable, Show, Ord, Enum, Bounded) -- | Pixel formats describe the order of the color channels in memory. data PixelFormat = PxRGBA | PxABGR deriving (Eq, Data, Typeable, Show, Ord, Enum, Bounded) instance Show BitmapData where show _ = "BitmapData" -- | Generates the point path to display the bitmap centred bitmapPath :: Float -> Float -> [(Float, Float)] bitmapPath width height = [(-width', -height'), (width', -height'), (width', height'), (-width', height')] where width' = width / 2 height' = height / 2 -- | Frees the allocated memory given to OpenGL to avoid a memory leak freeBitmapData :: Ptr Word8 -> IO () freeBitmapData p = free p {-# INLINE freeBitmapData #-} gloss-rendering-1.10.3.3/Graphics/Gloss/Internals/Rendering/Circle.hs0000644000000000000000000002166712746253753023517 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | Fast(ish) rendering of circles. module Graphics.Gloss.Internals.Rendering.Circle ( renderCircle , renderArc) where import Graphics.Gloss.Internals.Rendering.Common import GHC.Exts 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 | sDiam < 16 = 16 | sDiam < 32 = 32 | otherwise = 64 {-# INLINE circleSteps #-} -- Circle --------------------------------------------------------------------- -- | Render a circle with the given thickness renderCircle :: Float -> Float -> Float -> Float -> Float -> IO () renderCircle posX posY scaleFactor radius_ thickness_ = go (abs radius_) (abs thickness_) where go radius thickness -- If the circle is smaller than a pixel, render it as a point. | thickness == 0 , radScreen <- scaleFactor * (radius + thickness / 2) , radScreen <= 1 = GL.renderPrimitive GL.Points $ GL.vertex $ GL.Vertex2 (gf posX) (gf posY) -- Render zero thickness circles with lines. | thickness == 0 , radScreen <- scaleFactor * radius , steps <- circleSteps radScreen = renderCircleLine posX posY steps radius -- Some thick circle. | radScreen <- scaleFactor * (radius + thickness / 2) , steps <- circleSteps radScreen = renderCircleStrip posX posY steps radius thickness -- | Render a circle as a line. renderCircleLine :: Float -> Float -> Int -> Float -> IO () renderCircleLine (F# posX) (F# posY) steps (F# rad) = let n = fromIntegral steps !(F# tStep) = (2 * pi) / n !(F# tStop) = (2 * pi) in GL.renderPrimitive GL.LineLoop $ renderCircleLine_step posX posY tStep tStop rad 0.0# {-# INLINE renderCircleLine #-} -- | Render a circle with a given thickness as a triangle strip renderCircleStrip :: Float -> Float -> Int -> Float -> Float -> IO () renderCircleStrip (F# posX) (F# posY) steps r width = let n = fromIntegral steps !(F# tStep) = (2 * pi) / n !(F# tStop) = (2 * pi) + (F# tStep) / 2 !(F# r1) = r - width / 2 !(F# r2) = r + width / 2 in GL.renderPrimitive GL.TriangleStrip $ renderCircleStrip_step posX posY tStep tStop r1 0.0# r2 (tStep `divideFloat#` 2.0#) {-# INLINE renderCircleStrip #-} -- Arc ------------------------------------------------------------------------ -- | Render an arc with the given thickness. renderArc :: Float -> Float -> Float -> Float -> Float -> Float -> Float -> IO () renderArc posX posY scaleFactor radius_ a1 a2 thickness_ = go (abs radius_) (abs thickness_) where go radius thickness -- Render zero thickness arcs with lines. | thickness == 0 , radScreen <- scaleFactor * radius , steps <- circleSteps radScreen = renderArcLine posX posY steps radius a1 a2 -- Some thick arc. | radScreen <- scaleFactor * (radius + thickness / 2) , steps <- circleSteps radScreen = renderArcStrip posX posY steps radius a1 a2 thickness -- | Render an arc as a line. renderArcLine :: Float -> Float -> Int -> Float -> Float -> Float -> IO () renderArcLine (F# posX) (F# posY) steps (F# rad) a1 a2 = let n = fromIntegral steps !(F# tStep) = (2 * pi) / n !(F# tStart) = degToRad a1 !(F# tStop) = degToRad a2 + if a1 >= a2 then 2 * pi else 0 -- force the line to end at the desired angle endVertex = addPointOnCircle posX posY rad tStop in GL.renderPrimitive GL.LineStrip $ do renderCircleLine_step posX posY tStep tStop rad tStart endVertex {-# INLINE renderArcLine #-} -- | Render an arc with a given thickness as a triangle strip renderArcStrip :: Float -> Float -> Int -> Float -> Float -> Float -> Float -> IO () renderArcStrip (F# posX) (F# posY) steps r a1 a2 width = let n = fromIntegral steps tStep = (2 * pi) / n t1 = normalizeAngle $ degToRad a1 t2 = normalizeAngle $ degToRad a2 (tStart, tStop) = if t1 <= t2 then (t1, t2) else (t2, t1) tDiff = tStop - tStart tMid = tStart + tDiff / 2 !(F# tStep') = tStep !(F# tStep2') = tStep / 2 !(F# tStart') = tStart !(F# tStop') = tStop !(F# tCut') = tStop - tStep !(F# tMid') = tMid !(F# r1') = r - width / 2 !(F# r2') = r + width / 2 in GL.renderPrimitive GL.TriangleStrip $ do -- start vector addPointOnCircle posX posY r1' tStart' addPointOnCircle posX posY r2' tStart' -- If we don't have a complete step then just drop a point -- between the two ending lines. if tDiff < tStep then do addPointOnCircle posX posY r1' tMid' -- end vectors addPointOnCircle posX posY r2' tStop' addPointOnCircle posX posY r1' tStop' else do renderCircleStrip_step posX posY tStep' tCut' r1' tStart' r2' (tStart' `plusFloat#` tStep2') -- end vectors addPointOnCircle posX posY r1' tStop' addPointOnCircle posX posY r2' tStop' {-# INLINE renderArcStrip #-} -- Step functions ------------------------------------------------------------- renderCircleLine_step :: Float# -> Float# -> Float# -> Float# -> Float# -> Float# -> IO () renderCircleLine_step posX posY tStep tStop rad tt | 1# <- tt `geFloat#` tStop = return () | otherwise = do addPointOnCircle posX posY rad tt renderCircleLine_step posX posY tStep tStop rad (tt `plusFloat#` tStep) {-# INLINE renderCircleLine_step #-} renderCircleStrip_step :: Float# -> Float# -> Float# -> Float# -> Float# -> Float# -> Float# -> Float# -> IO () renderCircleStrip_step posX posY tStep tStop r1 t1 r2 t2 | 1# <- t1 `geFloat#` tStop = return () | otherwise = do addPointOnCircle posX posY r1 t1 addPointOnCircle posX posY r2 t2 renderCircleStrip_step posX posY tStep tStop r1 (t1 `plusFloat#` tStep) r2 (t2 `plusFloat#` tStep) {-# INLINE renderCircleStrip_step #-} addPoint :: Float# -> Float# -> IO () addPoint x y = GL.vertex $ GL.Vertex2 (gf (F# x)) (gf (F# y)) {-# INLINE addPoint #-} addPointOnCircle :: Float# -> Float# -> Float# -> Float# -> IO () addPointOnCircle posX posY rad tt = addPoint (posX `plusFloat#` (rad `timesFloat#` (cosFloat# tt))) (posY `plusFloat#` (rad `timesFloat#` (sinFloat# tt))) {-# INLINE addPointOnCircle #-} -- | Convert degrees to radians {-# INLINE degToRad #-} degToRad :: Float -> Float degToRad d = d * pi / 180 -- | 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) {- 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 -} gloss-rendering-1.10.3.3/Graphics/Gloss/Internals/Rendering/Color.hs0000644000000000000000000000113412746253753023357 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Rendering.Color where import Graphics.Gloss.Internals.Data.Color import Unsafe.Coerce import qualified Graphics.Rendering.OpenGL.GL as GL -- | Convert one of our Colors to OpenGL's representation. glColor4OfColor :: Color -> GL.Color4 a glColor4OfColor color = case color of RGBA r g b a -> let rF = unsafeCoerce r gF = unsafeCoerce g bF = unsafeCoerce b aF = unsafeCoerce a in GL.Color4 rF gF bF aF {-# INLINE glColor4OfColor #-} gloss-rendering-1.10.3.3/Graphics/Gloss/Internals/Rendering/Common.hs0000644000000000000000000000437412746253753023542 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Rendering.Common ( gf, gsizei , withModelview , withClearBuffer) where import Unsafe.Coerce import Graphics.Gloss.Internals.Data.Color import Graphics.Gloss.Internals.Rendering.Color import Graphics.Rendering.OpenGL (($=)) import qualified Graphics.Rendering.OpenGL.GL as GL -- | The OpenGL library doesn't seem to provide a nice way convert -- a Float to a GLfloat, even though they're the same thing -- under the covers. -- -- Using realToFrac is too slow, as it doesn't get fused in at -- least GHC 6.12.1 -- gf :: Float -> GL.GLfloat gf x = unsafeCoerce x {-# INLINE gf #-} -- | Used for similar reasons to above gsizei :: Int -> GL.GLsizei gsizei x = unsafeCoerce x {-# INLINE gsizei #-} -- | Set up the OpenGL rendering context for orthographic projection and run an -- action to draw the model. withModelview :: (Int, Int) -- ^ Width and height of window. -> IO () -- ^ Action to perform. -> IO () withModelview (sizeX, sizeY) action = do GL.matrixMode $= GL.Projection GL.preservingMatrix $ do -- setup the co-ordinate system 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 -- an action to draw the model. withClearBuffer :: Color -- ^ Background color -> IO () -- ^ Action to perform -> IO () withClearBuffer clearColor action = do -- initialization (done every time in this case) -- we don't need the depth buffer for 2d. GL.depthFunc GL.$= Just GL.Always -- always clear the buffer to white GL.clearColor GL.$= glColor4OfColor clearColor -- on every loop GL.clear [GL.ColorBuffer, GL.DepthBuffer] GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat) action gloss-rendering-1.10.3.3/Graphics/Gloss/Internals/Rendering/Picture.hs0000644000000000000000000003117012746253753023717 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Gloss.Internals.Rendering.Picture (renderPicture) where import Graphics.Gloss.Internals.Rendering.State import Graphics.Gloss.Internals.Rendering.Common import Graphics.Gloss.Internals.Rendering.Circle import Graphics.Gloss.Internals.Rendering.Bitmap import Graphics.Gloss.Internals.Data.Picture import Graphics.Gloss.Internals.Data.Color import System.Mem.StableName import Foreign.ForeignPtr import Data.IORef import Data.List import Control.Monad import Graphics.Rendering.OpenGL (($=), get) import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.GLU.Errors as GLU import qualified Graphics.UI.GLUT as GLUT -- | Render a picture into the current OpenGL context. -- -- Assumes that the OpenGL matrix mode is set to @Modelview@ -- renderPicture :: State -- ^ Current rendering state. -> Float -- ^ View port scale, which controls the level of detail. -- Use 1.0 to start with. -> Picture -- ^ Picture to render. -> IO () renderPicture state circScale picture = 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 circScale picture = {-# SCC "drawComponent" #-} case picture of -- nothin' Blank -> return () -- line Line path -> GL.renderPrimitive GL.LineStrip $ vertexPFs path -- polygon (where?) Polygon path | stateWireframe state -> GL.renderPrimitive GL.LineLoop $ vertexPFs path | otherwise -> GL.renderPrimitive GL.Polygon $ vertexPFs path -- circle Circle radius -> renderCircle 0 0 circScale radius 0 ThickCircle radius thickness -> renderCircle 0 0 circScale radius thickness -- arc Arc a1 a2 radius -> renderArc 0 0 circScale radius a1 a2 0 ThickArc a1 a2 radius thickness -> renderArc 0 0 circScale radius a1 a2 thickness -- stroke text -- text looks weird when we've got blend on, -- so disable it during the renderString call. Text str -> do GL.blend $= GL.Disabled GL.preservingMatrix $ GLUT.renderString GLUT.Roman str GL.blend $= GL.Enabled -- colors with float components. Color col p | stateColor state -> do oldColor <- get GL.currentColor let RGBA r g b a = col GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a) drawPicture state circScale p GL.currentColor $= oldColor | otherwise -> drawPicture state circScale p -- Translation -------------------------- -- Easy translations are done directly to avoid calling GL.perserveMatrix. Translate posX posY (Circle radius) -> renderCircle posX posY circScale radius 0 Translate posX posY (ThickCircle radius thickness) -> renderCircle posX posY circScale radius thickness Translate posX posY (Arc a1 a2 radius) -> renderArc posX posY circScale radius a1 a2 0 Translate posX posY (ThickArc a1 a2 radius thickness) -> renderArc posX posY circScale radius a1 a2 thickness Translate tx ty (Rotate deg p) -> GL.preservingMatrix $ do GL.translate (GL.Vector3 (gf tx) (gf ty) 0) GL.rotate (gf deg) (GL.Vector3 0 0 (-1)) drawPicture state circScale p Translate tx ty p -> GL.preservingMatrix $ 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) -> 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 state circScale p -- Scale -------------------------------- Scale sx sy p -> GL.preservingMatrix $ 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 let rowInfo = case rowOrder (bitmapFormat imgData) of BottomToTop -> [(0,0), (1,0), (1,1), (0,1)] TopToBottom -> [(0,1), (1,1), (1,0), (0,0)] -- 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_ (\(pX, pY) (tX, tY) -> do GL.texCoord $ GL.TexCoord2 (gf tX) (gf tY) GL.vertex $ GL.Vertex2 (gf pX) (gf pY)) (bitmapPath (fromIntegral width) (fromIntegral height)) rowInfo -- Restore color GL.currentColor $= oldColor -- Disable texturing GL.texture GL.Texture2D $= GL.Disabled -- Free uncachable texture objects. freeTexture tex Pictures ps -> mapM_ (drawPicture state circScale) ps -- Errors --------------------------------------------------------------------- checkErrors :: String -> IO () checkErrors place = do errors <- get $ GLU.errors when (not $ null errors) $ mapM_ (handleError place) errors handleError :: String -> GLU.Error -> IO () handleError place err = case err of GLU.Error GLU.StackOverflow _ -> error $ unlines [ "Gloss / OpenGL Stack Overflow " ++ show place , " This program uses the Gloss vector graphics library, which tried to" , " draw a picture using more nested transforms (Translate/Rotate/Scale)" , " than your OpenGL implementation supports. The OpenGL spec requires" , " all implementations to have a transform stack depth of at least 32," , " and Gloss tries not to push the stack when it doesn't have to, but" , " that still wasn't enough." , "" , " You should complain to your harware vendor that they don't provide" , " a better way to handle this situation at the OpenGL API level." , "" , " To make this program work you'll need to reduce the number of nested" , " transforms used when defining the Picture given to Gloss. Sorry." ] -- Issue #32: Spurious "Invalid Operation" errors under Windows 7 64-bit. -- When using GLUT under Windows 7 it complains about InvalidOperation, -- but doesn't provide any other details. All the examples look ok, so -- we're just ignoring the error for now. GLU.Error GLU.InvalidOperation _ -> return () _ -> error $ unlines [ "Gloss / OpenGL Internal Error " ++ show place , " Please report this on haskell-gloss@googlegroups.com." , show err ] -- Textures ------------------------------------------------------------------- -- | Load a texture. -- If we've seen it before then use the pre-installed one from the texture -- cache, otherwise load it into OpenGL. loadTexture :: IORef [Texture] -> Int -> Int -> BitmapData -> Bool -> IO Texture loadTexture refTextures width height imgData cacheMe = do textures <- readIORef refTextures -- Try and find this same texture in the cache. name <- makeStableName imgData let mTexCached = find (\tex -> texName tex == name && texWidth tex == width && texHeight tex == height) textures case mTexCached of Just tex -> return tex Nothing -> do tex <- installTexture width height imgData cacheMe when cacheMe $ writeIORef refTextures (tex : textures) return tex -- | Install a texture into OpenGL. installTexture :: Int -> Int -> BitmapData -> Bool -> IO Texture installTexture width height bitmapData@(BitmapData _ fmt fptr) cacheMe = do let glFormat = case pixelFormat fmt of PxABGR -> GL.RGBA PxRGBA -> GL.ABGR -- Allocate texture handle for texture [tex] <- GL.genObjectNames 1 GL.textureBinding GL.Texture2D $= Just tex -- Sets the texture in imgData as the current texture -- This copies the data from the pointer into OpenGL texture memory, -- so it's ok if the foreignptr gets garbage collected after this. withForeignPtr fptr $ \ptr -> GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 (GL.TextureSize2D (gsizei width) (gsizei height)) 0 (GL.PixelData glFormat GL.UnsignedInt8888 ptr) -- Make a stable name that we can use to identify this data again. -- If the user gives us the same texture data at the same size then we -- can avoid loading it into texture memory again. name <- makeStableName bitmapData return Texture { texName = name , texWidth = width , texHeight = height , texData = fptr , texObject = tex , texCacheMe = cacheMe } -- | If this texture does not have its `cacheMe` flag set then delete it from -- OpenGL and free the GPU memory. freeTexture :: Texture -> IO () freeTexture tex | texCacheMe tex = return () | otherwise = GL.deleteObjectNames [texObject tex] -- Utils ---------------------------------------------------------------------- -- | Turn alpha blending on or off setBlendAlpha :: Bool -> IO () setBlendAlpha state | state = do GL.blend $= GL.Enabled GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) | otherwise = do GL.blend $= GL.Disabled GL.blendFunc $= (GL.One, GL.Zero) -- | Turn line smoothing on or off setLineSmooth :: Bool -> IO () setLineSmooth state | state = GL.lineSmooth $= GL.Enabled | otherwise = GL.lineSmooth $= GL.Disabled vertexPFs :: [(Float, Float)] -> IO () vertexPFs [] = return () vertexPFs ((x, y) : rest) = do GL.vertex $ GL.Vertex2 (gf x) (gf y) vertexPFs rest {-# INLINE vertexPFs #-} gloss-rendering-1.10.3.3/Graphics/Gloss/Internals/Rendering/State.hs0000644000000000000000000000425412746253753023367 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- | Rendering options module Graphics.Gloss.Internals.Rendering.State ( State (..) , initState , Texture (..)) where import Graphics.Gloss.Internals.Data.Picture import Foreign.ForeignPtr import System.Mem.StableName import Data.Word import Data.IORef import qualified Graphics.Rendering.OpenGL.GL as GL -- | Abstract Gloss render state which holds references to textures -- loaded into the GPU context. data State = State { -- | Whether to use color stateColor :: !Bool -- | Whether to force wireframe mode only , stateWireframe :: !Bool -- | Whether to use alpha blending , stateBlendAlpha :: !Bool -- | Whether to use line smoothing , stateLineSmooth :: !Bool -- | Cache of Textures that we've sent to OpenGL. , stateTextures :: !(IORef [Texture]) } -- | A texture that we've sent to OpenGL. data Texture = Texture { -- | Stable name derived from the `BitmapData` that the user gives us. texName :: StableName BitmapData -- | Width of the image, in pixels. , texWidth :: Int -- | Height of the image, in pixels. , texHeight :: Int -- | Pointer to the Raw texture data. , texData :: ForeignPtr Word8 -- | The OpenGL texture object. , texObject :: GL.TextureObject -- | Whether we want to leave this in OpenGL texture memory between frames. , texCacheMe :: Bool } -- | A mutable render state holds references to the textures currently loaded -- into the OpenGL context. To ensure that textures are cached in GPU memory, -- pass the same `State` each time you call `displayPicture` or `renderPicture`. initState :: IO State initState = do textures <- newIORef [] return State { stateColor = True , stateWireframe = False , stateBlendAlpha = True , stateLineSmooth = False , stateTextures = textures }