gloss-rendering 1.9.1.1 → 1.9.2.1

raw patch · 29 files changed

+1260/−2477 lines, 29 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Graphics/Gloss/Data/Color.hs +0/−237
• Graphics/Gloss/Data/Display.hs +0/−13
• Graphics/Gloss/Data/Extent.hs +0/−195
• Graphics/Gloss/Data/Picture.hs +0/−351
• Graphics/Gloss/Data/Point.hs +0/−51
• Graphics/Gloss/Data/Quad.hs +0/−17
• Graphics/Gloss/Data/QuadTree.hs +0/−191
• Graphics/Gloss/Data/Vector.hs +0/−91
• Graphics/Gloss/Data/ViewPort.hs +0/−57
• Graphics/Gloss/Geometry.hs +0/−8
• Graphics/Gloss/Geometry/Angle.hs +0/−25
• Graphics/Gloss/Geometry/Line.hs +0/−326
• Graphics/Gloss/Internals/Color.hs +0/−19
• Graphics/Gloss/Internals/Data/Color.hs +116/−0
• Graphics/Gloss/Internals/Data/Picture.hs +196/−0
• Graphics/Gloss/Internals/Render/Bitmap.hs +0/−86
• Graphics/Gloss/Internals/Render/Circle.hs +0/−246
• Graphics/Gloss/Internals/Render/Common.hs +0/−50
• Graphics/Gloss/Internals/Render/Picture.hs +0/−376
• Graphics/Gloss/Internals/Render/State.hs +0/−70
• Graphics/Gloss/Internals/Rendering/Bitmap.hs +86/−0
• Graphics/Gloss/Internals/Rendering/Circle.hs +257/−0
• Graphics/Gloss/Internals/Rendering/Color.hs +19/−0
• Graphics/Gloss/Internals/Rendering/Common.hs +80/−0
• Graphics/Gloss/Internals/Rendering/Picture.hs +355/−0
• Graphics/Gloss/Internals/Rendering/State.hs +72/−0
• Graphics/Gloss/Render.hs +0/−46
• Graphics/Gloss/Rendering.hs +60/−0
• gloss-rendering.cabal +19/−22

@@ -1,237 +0,0 @@---- | Predefined and custom colors.-module Graphics.Gloss.Data.Color-	( -	-- ** Color data type-	  Color-	, makeColor-        , makeColor'-        , makeColor8-	, rawColor-	, rgbaOfColor--	-- ** Color functions-	, mixColors-	, addColors-	, dim,   bright-	, light, dark--	-- ** Pre-defined colors-	, greyN,  black,  white-	-- *** Primary-	, red,    green,  blue-	-- *** Secondary-	, yellow,     cyan,       magenta-	-	-- *** Tertiary-	, rose,   violet, azure, aquamarine, chartreuse, orange-	)-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- {-# 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 (*) #-}- (*) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _)-        = RGBA (r1 * r2) (g1 * g2) (b1 * b2) 1-- {-# INLINE abs #-}- abs (RGBA r1 g1 b1 _)-        = RGBA (abs r1) (abs g1) (abs b1) 1-- {-# INLINE signum #-}- signum (RGBA r1 g1 b1 _)-        = RGBA (signum r1) (signum g1) (signum b1) 1-        - {-# INLINE fromInteger #-}- fromInteger i-  = let f = fromInteger i-    in  RGBA f f f 1----- | 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. ---   You promise that all components are clamped to the range [0..1]-makeColor' :: Float -> Float -> Float -> Float -> Color-makeColor' r g b a-        = RGBA r g b a-{-# INLINE makeColor' #-}----- | Make a custom color. All components are clamped to the range [0..255].-makeColor8 -	:: Int 		-- ^ Red component.-	-> Int 		-- ^ Green component.-	-> Int 		-- ^ Blue component.-	-> Int 		-- ^ Alpha component.-	-> Color--makeColor8 r g b a-	= clampColor -	$ RGBA 	(fromIntegral r / 255) -		(fromIntegral g / 255)-		(fromIntegral b / 255)-		(fromIntegral a / 255)-{-# INLINE makeColor8 #-}--	--- | 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 #-}-		---- | Make a custom color.---   Components should be in the range [0..1] but this is not checked.-rawColor-	:: Float	-- ^ Red component.-	-> Float	-- ^ Green component.-	-> Float 	-- ^ Blue component.-	-> Float 	-- ^ Alpha component.-	-> Color--rawColor = RGBA-{-# INLINE rawColor #-}----- Internal ---- | Clamp components of a 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)---- | Normalise a color to the value of its largest RGB component.-normaliseColor :: Color -> Color-normaliseColor cc- = let	(r, g, b, a)	= rgbaOfColor cc-	m		= maximum [r, g, b]-   in	RGBA (r / m) (g / m) (b / m) a----- Color functions ---------------------------------------------------------------- | 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.--mixColors ratio1 ratio2 c1 c2- = let	RGBA r1 g1 b1 a1	= c1-	RGBA r2 g2 b2 a2	= c2--	total	= ratio1 + ratio2-	m1	= ratio1 / total-	m2	= ratio2 / total--   in	RGBA 	(m1 * r1 + m2 * r2)-		(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.-addColors :: Color -> Color -> Color-addColors c1 c2- = let	RGBA r1 g1 b1 a1	= c1-	RGBA r2 g2 b2 a2	= c2--   in	normaliseColor -	 $ RGBA (r1 + r2)-		(g1 + g2)-		(b1 + b2)-		((a1 + a2) / 2)----- | Make a dimmer version of a color, scaling towards black.-dim :: Color -> Color-dim (RGBA r g b a)-	= RGBA (r / 1.2) (g / 1.2) (b / 1.2) a--	--- | Make a brighter version of a color, scaling towards white.-bright :: Color -> Color-bright (RGBA r g b a)-	= clampColor-	$ RGBA (r * 1.2) (g * 1.2) (b * 1.2) a----- | Lighten a color, adding white.-light :: Color -> Color-light (RGBA r g b a)-	= clampColor-	$ RGBA (r + 0.2) (g + 0.2) (b + 0.2) a-	-	--- | Darken a color, adding black.-dark :: Color -> Color-dark (RGBA r g b a)-	= clampColor-	$ RGBA (r - 0.2) (g - 0.2) (b - 0.2) a----- Pre-defined Colors ------------------------------------------------------------ | A greyness of a given magnitude.-greyN 	:: Float 	-- ^ Range is 0 = black, to 1 = white.-	-> Color-greyN n		= RGBA n   n   n   1.0--black, white :: Color-black		= RGBA 0.0 0.0 0.0 1.0-white		= RGBA 1.0 1.0 1.0 1.0---- Colors from the additive color wheel.-red, green, blue :: Color-red		= RGBA 1.0 0.0 0.0 1.0-green		= RGBA 0.0 1.0 0.0 1.0-blue		= RGBA 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---- 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

@@ -1,13 +0,0 @@--module Graphics.Gloss.Data.Display-        (Display(..))-where---- | Describes how Gloss should display its output.-data Display-        -- | Display in a window with the given name, size and position.-        = InWindow   String (Int, Int) (Int, Int)--        -- | Display full screen with a drawing area of the given size.-        | FullScreen (Int, Int) -        deriving (Eq, Read, Show)

@@ -1,195 +0,0 @@-{-# LANGUAGE PatternGuards #-}---- | Represents an integral rectangular area of the 2D plane.---   Using `Int`s (instead of `Float`s) for the bounds means we can safely---   compare extents for equality.-module Graphics.Gloss.Data.Extent-	( Extent-	, Coord-	, makeExtent-	, takeExtent-	, squareExtent-	, sizeOfExtent-	, isUnitExtent-	, coordInExtent-	, pointInExtent-	, centerCoordOfExtent-	, cutQuadOfExtent-	, quadOfCoord-	, pathToCoord-	, intersectSegExtent-	, touchesSegExtent)-where-import Graphics.Gloss.Data.Point-import Graphics.Gloss.Data.Quad-import Graphics.Gloss.Geometry.Line-import Data.Maybe----- | A rectangular area of the 2D plane.---   We keep the type abstract to ensure that invalid extents cannot be---   constructed.-data Extent-	= Extent Int Int Int Int-	deriving (Eq, Show)----- | An integral coordinate.-type Coord-	= (Int, Int)----- | Construct an extent.---	The north value must be > south, and east > west, else `error`.-makeExtent -	:: Int 	-- ^ y max (north)-	-> Int 	-- ^ y min (south)-	-> Int 	-- ^ x max (east)-	-> Int 	-- ^ x min (west)-	-> Extent--makeExtent n s e w-	| n >= s, e >= w-	= Extent n s e w-	-	| otherwise-	= error "Graphics.Gloss.Geometry.Extent.makeExtent: invalid extent"----- | Take the NSEW components of an extent.-takeExtent :: Extent -> (Int, Int, Int, Int)-takeExtent (Extent n s e w)-	= (n, s, e, w)----- | A square extent of a given size.-squareExtent :: Int -> Extent-squareExtent i-	= Extent i 0 i 0----- | Get the width and height of an extent.-sizeOfExtent :: Extent -> (Int, Int)-sizeOfExtent (Extent n s e w)-	= (e - w, n - s)----- | Check if an extent is a square with a width and height of 1.-isUnitExtent :: Extent -> Bool-isUnitExtent extent-	= sizeOfExtent extent == (1, 1)----- | Check whether a coordinate lies inside an extent.-coordInExtent :: Extent -> Coord -> Bool-coordInExtent (Extent n s e w) (x, y)-	=  x >= w && x < e-	&& y >= s && y < n----- | Check whether a point lies inside an extent.-pointInExtent :: Extent -> Point -> Bool-pointInExtent (Extent n s e w) (x, y)- = let	n'	= fromIntegral n-	s'	= fromIntegral s-	e'	= fromIntegral e-	w'	= fromIntegral w-	-   in	x >= w' && x <= e'-     && y >= s' && y <= n'----- | Get the coordinate that lies at the center of an extent.-centerCoordOfExtent :: Extent -> (Int, Int)-centerCoordOfExtent (Extent n s e w)- = 	( w + (e - w) `div` 2-	, s + (n - s) `div` 2)----- | Cut one quadrant out of an extent.-cutQuadOfExtent :: Quad -> Extent -> Extent-cutQuadOfExtent quad (Extent n s e w)  - = let	hheight	= (n - s) `div` 2-	hwidth	= (e - w) `div` 2-   in	case quad of-	  	NW -> Extent n (s + hheight)  (e - hwidth) w-		NE -> Extent n (s + hheight)  e (w + hwidth)-		SW -> Extent (n - hheight) s  (e - hwidth) w-		SE -> Extent (n - hheight) s  e (w + hwidth)-	-	--- | Get the quadrant that this coordinate lies in, if any.-quadOfCoord :: Extent -> Coord -> Maybe Quad-quadOfCoord extent coord- 	= listToMaybe -	$ filter (\q -> coordInExtent (cutQuadOfExtent q extent) coord)-	$ allQuads--	--- | Constuct a path to a particular coordinate in an extent.-pathToCoord :: Extent -> Coord -> Maybe [Quad]-pathToCoord extent coord-	| isUnitExtent extent	-	= Just []-	-	| otherwise-	= do	quad	<- quadOfCoord extent coord-		rest	<- pathToCoord (cutQuadOfExtent quad extent) coord-		return	$ quad : rest----- | If a line segment (P1-P2) intersects the outer edge of an extent then---   return the intersection point, that is closest to P1, if any.---   If P1 is inside the extent then `Nothing`.------   @---                   P2---                  /---            ----/----            | /  |---            +    |---           /---------         / ---        P1---   @--- -intersectSegExtent :: Point -> Point -> Extent -> Maybe Point-intersectSegExtent p1@(x1, y1) p2 (Extent n' s' e' w')-	-- starts below extent-	| y1 < s-	, Just pos	<- intersectSegHorzSeg p1 p2 s w e-	= Just pos-	-	-- starts above extent-	| y1 > n-	, Just pos	<- intersectSegHorzSeg p1 p2 n w e-	= Just pos--	-- starts left of extent-	| x1 < w-	, Just pos	<- intersectSegVertSeg p1 p2 w s n-	= Just pos-	-	-- starts right of extent-	| x1 > e-	, Just pos	<- intersectSegVertSeg p1 p2 e s n-	= Just pos--	-- must be starting inside extent.-	| otherwise-	= Nothing-	-	where	n	= fromIntegral n'-		s	= fromIntegral s'-		e	= fromIntegral e'-		w	= fromIntegral w'----- | Check whether a line segment's endpoints are inside an extent, or if it---   intersects with the boundary.-touchesSegExtent :: Point -> Point -> Extent -> Bool-touchesSegExtent p1 p2 extent-	=   pointInExtent extent p1-       	 || pointInExtent extent p2-	 || isJust (intersectSegExtent p1 p2 extent)-

@@ -1,351 +0,0 @@---- | Data types for representing pictures.-module Graphics.Gloss.Data.Picture-	( Point-	, Vector-	, Path-	, Picture(..)-	, BitmapData--	-- * Aliases for Picture constructors-	, blank-        , polygon-        , line-        , circle, thickCircle-        , arc,    thickArc-        , text-        , bitmap-	, color-        , translate, rotate, scale-	, pictures--	-- * Compound shapes- 	, lineLoop- 	, circleSolid-        , arcSolid-        , sectorWire-	, rectanglePath-        , rectangleWire-        , rectangleSolid-	, rectangleUpperPath-        , rectangleUpperWire-        , rectangleUpperSolid--        -- * Loading Bitmaps-        , bitmapOfForeignPtr-        , bitmapOfByteString-        , bitmapOfBMP-        , loadBMP)--where-import Graphics.Gloss.Data.Color-import Graphics.Gloss.Data.Point-import Graphics.Gloss.Data.Vector-import Graphics.Gloss.Geometry.Angle-import Graphics.Gloss.Internals.Render.Bitmap-import Codec.BMP-import Foreign.ForeignPtr-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 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-        --  between frames for speed. If you are programatically generating-        --  the image for each frame then use `False`. If you have loaded it-        --  from a file then use `True`.-	| Bitmap	Int	Int 	BitmapData Bool--	-- Color -------------------------------------------	-- | 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----- Constructors ------------------------------------------------------------------- NOTE: The docs here should be identical to the ones on the constructors.---- | A blank picture, with nothing in it.-blank :: Picture-blank	= Blank---- | A convex polygon filled with a solid color.-polygon :: Path -> Picture-polygon = Polygon---- | A line along an arbitrary path.-line :: Path -> Picture-line 	= Line---- | A circle with the given radius.-circle  :: Float  -> Picture-circle 	= Circle---- | A circle with the given thickness and radius.---   If the thickness is 0 then this is equivalent to `Circle`.-thickCircle  :: Float -> Float -> Picture-thickCircle = ThickCircle---- | A circular arc drawn counter-clockwise between two angles (in degrees) ---   at the given radius.-arc     :: Float -> Float -> Float -> Picture-arc = Arc---- | A circular arc drawn counter-clockwise between two angles (in degrees),---   with the given radius  and thickness.---   If the thickness is 0 then this is equivalent to `Arc`.-thickArc :: Float -> Float -> Float -> Float -> Picture-thickArc = ThickArc---- | Some text to draw with a vector font.-text :: String -> Picture-text = Text---- | A bitmap image with a width, height and a Vector holding the ---   32-bit RGBA bitmap data.--- ---  The boolean flag controls whether Gloss should cache the data---  between frames for speed.---  If you are programatically generating the image for---  each frame then use `False`.  ---  If you have loaded it from a file then use `True`.-bitmap  :: Int -> Int -> BitmapData -> Bool -> Picture-bitmap = Bitmap---- | A picture drawn with this color.-color :: Color -> Picture -> Picture-color = Color---- | A picture translated by the given x and y coordinates.-translate :: Float -> Float -> Picture -> Picture-translate = Translate---- | A picture rotated clockwise by the given angle (in degrees).-rotate  :: Float -> Picture -> Picture-rotate = Rotate---- | A picture scaled by the given x and y factors.-scale   :: Float -> Float -> Picture -> Picture-scale = Scale---- | A picture consisting of several others.-pictures :: [Picture] -> Picture-pictures = Pictures----- Bitmaps ----------------------------------------------------------------------- | O(1). Use a `ForeignPtr` of RGBA data as a bitmap with the given---   width and height.----   The boolean flag controls whether Gloss should cache the data---   between frames for speed. If you are programatically generating---   the image for each frame then use `False`. If you have loaded it---   from a file then use `True`.-bitmapOfForeignPtr :: Int -> Int -> ForeignPtr Word8 -> Bool -> Picture-bitmapOfForeignPtr width height fptr cacheMe- = let  len     = width * height * 4-        bdata   = BitmapData len 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`.-{-# NOINLINE bitmapOfByteString #-}-bitmapOfByteString :: Int -> Int -> ByteString -> Bool -> Picture-bitmapOfByteString width height 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 fptr-        return $ Bitmap width height bdata cacheMe----- | O(size). Copy a `BMP` file into a bitmap.-{-# NOINLINE bitmapOfBMP #-}-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 fptr-        reverseRGBA bdata--        return $ Bitmap width height bdata True----- | 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----- Other Shapes ------------------------------------------------------------------ | A closed loop along a path.-lineLoop :: Path -> Picture-lineLoop []	= Line []-lineLoop (x:xs)	= Line ((x:xs) ++ [x])----- Circles and Arcs -------------------------------------------------------------- | A solid circle with the given radius.-circleSolid :: Float -> Picture-circleSolid r -        = thickCircle (r/2) r----- | A solid arc, drawn counter-clockwise between two angles at the given radius.-arcSolid  :: Float -> Float -> Float -> Picture-arcSolid a1 a2 r -        = thickArc a1 a2 (r/2) r ----- | A wireframe sector of a circle. ---   An arc is draw counter-clockwise from the first to the second angle at---   the given radius. Lines are drawn from the origin to the ends of the arc.-------   NOTE: We take the absolute value of the radius incase it's negative.---   It would also make sense to draw the sector flipped around the ---   origin, but I think taking the absolute value will be less surprising---   for the user.--- -sectorWire :: Float -> Float -> Float -> Picture-sectorWire a1 a2 r_- = let r        = abs r_-   in  Pictures -        [ Arc a1 a2 r-        , Line [(0, 0), (r * cos (degToRad a1), r * sin (degToRad a1))]-        , Line [(0, 0), (r * cos (degToRad a2), r * sin (degToRad a2))] ]----- Rectangles -------------------------------------------------------------------- NOTE: Only the first of these rectangle functions has haddocks on the---       arguments to reduce the amount of noise in the extracted docs.---- | A path representing a rectangle centered about the origin-rectanglePath -        :: Float        -- ^ width of rectangle-        -> Float        -- ^ height of rectangle-        -> Path-rectanglePath sizeX sizeY			- = let	sx	= sizeX / 2-	sy	= sizeY / 2-   in	[(-sx, -sy), (-sx, sy), (sx, sy), (sx, -sy)]----- | A wireframe rectangle centered about the origin.-rectangleWire :: Float -> Float -> Picture-rectangleWire sizeX sizeY-	= lineLoop $ rectanglePath sizeX sizeY----- | A wireframe rectangle in the y > 0 half of the x-y plane.-rectangleUpperWire :: Float -> Float -> Picture-rectangleUpperWire sizeX sizeY-	= lineLoop $ rectangleUpperPath sizeX sizeY----- | A path representing a rectangle in the y > 0 half of the x-y plane.-rectangleUpperPath :: Float -> Float -> Path-rectangleUpperPath sizeX sy- = let 	sx	= sizeX / 2-   in  	[(-sx, 0), (-sx, sy), (sx, sy), (sx, 0)]----- | A solid rectangle centered about the origin.-rectangleSolid :: Float -> Float -> Picture-rectangleSolid sizeX sizeY-	= Polygon $ rectanglePath sizeX sizeY----- | A solid rectangle in the y > 0 half of the x-y plane.-rectangleUpperSolid :: Float -> Float -> Picture-rectangleUpperSolid sizeX sizeY-	= Polygon  $ rectangleUpperPath sizeX sizeY-

@@ -1,51 +0,0 @@-{-# OPTIONS -fno-warn-missing-methods -fno-warn-orphans #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-module Graphics.Gloss.Data.Point-	( Point-	, pointInBox)-where---- | A point on the x-y plane.---   Points can also be treated as `Vector`s, so "Graphics.Gloss.Data.Vector"---   may also be useful.-type Point	= (Float, Float)			----- | Pretend a point is a number.---	Vectors aren't real numbes 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)----- | Test whether a point lies within a rectangular box that is oriented---   on the x-y plane. The points P1-P2 are opposing points of the box,---   but need not be in a particular order.------ @---    P2 +-------+---       |       |---       | + P0  |---       |       |---       +-------+ P1--- @----pointInBox -	:: 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

@@ -1,17 +0,0 @@--module Graphics.Gloss.Data.Quad-	( Quad(..)-	, allQuads)-where-	--- | Represents a Quadrant in the 2D plane.-data Quad-	= NW 	-- ^ North West-	| NE 	-- ^ North East-	| SW 	-- ^ South West-	| SE	-- ^ South East-	deriving (Show, Eq, Enum)---- | A list of all quadrants. Same as @[NW .. SE]@.-allQuads :: [Quad]-allQuads = [NW .. SE]

@@ -1,191 +0,0 @@-{-# LANGUAGE RankNTypes #-}---- | A QuadTree can be used to recursively divide up 2D space into quadrants.---   The smallest division corresponds to an unit `Extent`, so the total depth ---   of the tree will depend on what sized `Extent` you start with.-module Graphics.Gloss.Data.QuadTree-	( QuadTree (..)-	, emptyTree-	, emptyNode-	, takeQuadOfTree-	, liftToQuad-	, insertByPath-	, insertByCoord-	, lookupNodeByPath-	, lookupByPath-	, lookupByCoord-	, flattenQuadTree-	, flattenQuadTreeWithExtents)-where-import Graphics.Gloss.Data.Quad-import Graphics.Gloss.Data.Extent---- | The quad tree structure.-data QuadTree a-	-- | An empty node.-	= TNil--	-- | A leaf containint some value.-	| TLeaf a-	-	-- | A node with four children.-	| TNode (QuadTree a) (QuadTree a) 	-- NW NE-		(QuadTree a) (QuadTree a)	-- SW SE-	deriving Show----- | A `TNil` tree.-emptyTree :: QuadTree a-emptyTree = TNil----- | A node with `TNil`. for all its branches.-emptyNode :: QuadTree a-emptyNode = TNode TNil TNil TNil TNil----- | Get a quadrant from a node.---   If the tree does not have an outer node then `Nothing`.-takeQuadOfTree-	:: Quad-	-> QuadTree a-	-> Maybe (QuadTree a)--takeQuadOfTree quad tree- = case tree of-	TNil		-> Nothing-	TLeaf{}		-> Nothing-	TNode nw ne sw se-	 -> case quad of-		NW	-> Just nw-		NE	-> Just ne-		SW	-> Just sw-		SE	-> Just se----- | Apply a function to a quadrant of a node.---   If the tree does not have an outer node then return the original tree.-liftToQuad-	:: Quad-	-> (QuadTree a -> QuadTree a) -	-> QuadTree a  -> QuadTree a--liftToQuad quad f tree- = case tree of-	TNil		-> tree-	TLeaf{}		-> tree-	TNode nw ne sw se-	 -> case quad of-		NW	-> TNode (f nw) ne sw se-		NE	-> TNode nw (f ne) sw se-		SW	-> TNode nw ne (f sw) se-		SE	-> TNode nw ne sw (f se)-		 -		--- | Insert a value into the tree at the position given by a path.---   If the path intersects an existing `TLeaf` then return the original tree.-insertByPath :: [Quad] -> a -> QuadTree a -> QuadTree a-	-insertByPath [] x _-	= TLeaf x-	-insertByPath (q:qs) x tree- = case tree of-	TNil	-> liftToQuad q (insertByPath qs x) emptyNode-	TLeaf{}	-> tree-	TNode{}	-> liftToQuad q (insertByPath qs x) tree----- | Insert a value into the node containing this coordinate.---   The node is created at maximum depth, corresponding to an unit `Extent`.-insertByCoord :: Extent -> Coord -> a -> QuadTree a -> Maybe (QuadTree a)-insertByCoord extent coord x tree- = do	path	<- pathToCoord extent coord-	return	$  insertByPath path x tree----- | Lookup a node based on a path to it.-lookupNodeByPath-	:: [Quad]-	-> QuadTree a-	-> Maybe (QuadTree a)--lookupNodeByPath [] tree-	= Just tree-	-lookupNodeByPath (q:qs) tree- = case tree of-	TNil	-> Nothing-	TLeaf{}	-> Nothing-	TNode{}-	 -> let Just quad	= takeQuadOfTree q tree-	    in  lookupNodeByPath qs quad----- | Lookup an element based given a path to it.-lookupByPath :: [Quad] -> QuadTree a -> Maybe a-lookupByPath path tree- = case lookupNodeByPath path tree of-	Just (TLeaf x)	-> Just x-	_		-> Nothing----- | Lookup a node if a tree given a coordinate which it contains.-lookupByCoord -	:: forall a-	.  Extent 	-- ^ Extent that covers the whole tree.-	-> Coord 	-- ^ Coordinate of the value of interest.-	-> QuadTree a -	-> Maybe a-lookupByCoord extent coord tree- = do	path	<- pathToCoord extent coord-	lookupByPath path tree-	-	--- | Flatten a QuadTree into a list of its contained values, with coordinates.-flattenQuadTree -	:: forall a-	.  Extent 	-- ^ Extent that covers the whole tree.-	-> QuadTree a -	-> [(Coord, a)]-	-flattenQuadTree extentInit treeInit- = flatten' extentInit treeInit- where	flatten' extent tree- 	 = case tree of-		TNil	-> []-		TLeaf x	-		 -> let (_, s, _, w) = takeExtent extent-		    in  [((w, s), x)]--		TNode{}	-> concat $ map (flattenQuad extent tree) allQuads-			-	flattenQuad extent tree quad- 	 = let	extent'		= cutQuadOfExtent quad extent-		Just tree'	= takeQuadOfTree quad tree-   	   in	flatten' extent' tree'----- | Flatten a QuadTree into a list of its contained values, with coordinates.-flattenQuadTreeWithExtents-	:: forall a-	.  Extent 	-- ^ Extent that covers the whole tree.-	-> QuadTree a -	-> [(Extent, a)]-	-flattenQuadTreeWithExtents extentInit treeInit- = flatten' extentInit treeInit- where	flatten' extent tree- 	 = case tree of-		TNil	-> []-		TLeaf x	-		 -> [(extent, x)]--		TNode{}	-> concat $ map (flattenQuad extent tree) allQuads-			-	flattenQuad extent tree quad- 	 = let	extent'		= cutQuadOfExtent quad extent-		Just tree'	= takeQuadOfTree quad tree-   	   in	flatten' extent' tree'--

@@ -1,91 +0,0 @@-{-# OPTIONS -fno-warn-missing-methods #-}-{-# LANGUAGE TypeSynonymInstances #-}---- | Geometric functions concerning vectors.-module Graphics.Gloss.Data.Vector-	( Vector-	, magV-	, argV-	, dotV-	, detV-	, mulSV-	, rotateV-	, angleVV-	, normaliseV-	, unitVectorAtAngle )-where-import Graphics.Gloss.Data.Point-import Graphics.Gloss.Geometry.Angle---- | A vector can be treated as a point, and vis-versa.-type Vector	= Point----- | The magnitude of a vector.-magV :: Vector -> Float-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)-	= normaliseAngle $ atan2 y x-{-# INLINE argV #-}----- | The dot product of two vectors.-dotV :: Vector -> Vector -> Float-dotV (x1, x2) (y1, 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-{-# INLINE detV #-}----- | Multiply a vector by a scalar.-mulSV :: Float -> Vector -> Vector-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 * sin r + y * cos r)-{-# INLINE rotateV #-}----- | 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)--   in	aDiff	-{-# INLINE angleVV #-}----- | Normalise a vector, so it has a magnitude of 1.-normaliseV :: Vector -> Vector-normaliseV v	= mulSV (1 / magV v) v-{-# INLINE normaliseV #-}----- | Produce a unit vector at a given angle relative to the +ve x-axis.---	The provided angle is in radians.-unitVectorAtAngle :: Float -> Vector-unitVectorAtAngle r-	= (cos r, sin r)-{-# INLINE unitVectorAtAngle #-}-

@@ -1,57 +0,0 @@-module Graphics.Gloss.Data.ViewPort-	( ViewPort(..)-	, viewPortInit-	, applyViewPortToPicture-	, invertViewPort )-where-import Graphics.Gloss.Data.Vector-import Graphics.Gloss.Geometry.Angle-import Graphics.Gloss.Data.Picture (Picture(..))-import Graphics.Gloss.Data.Point----- | The 'ViewPort' represents the global transformation applied to the displayed picture.---      When the user pans, zooms, or rotates the display then this changes the 'ViewPort'.-data ViewPort-	= ViewPort { -	-- | Global translation.-	  viewPortTranslate	:: !(Float, Float)--	-- | Global rotation (in degrees).-	, viewPortRotate	:: !Float		--	-- | Global scaling (of both x and y coordinates).-	, viewPortScale		:: !Float		-	}-	-	--- | The initial state of the viewport.-viewPortInit :: ViewPort-viewPortInit-	= ViewPort-	{ viewPortTranslate	= (0, 0) -	, viewPortRotate	= 0-	, viewPortScale		= 1 -	}----- | Translates, rotates, and scales an image according to the 'ViewPort'.-applyViewPortToPicture :: ViewPort  -> Picture -> Picture-applyViewPortToPicture-	ViewPort	{ viewPortScale		= scale-                        , viewPortTranslate	= (transX, transY)-			, viewPortRotate	= rotate }-	= Scale scale scale . Rotate rotate . Translate transX transY----- | Takes a point using screen coordinates, and uses the `ViewPort` to convert---   it to Picture coordinates. This is the inverse of `applyViewPortToPicture` ---   for points.-invertViewPort :: ViewPort -> Point -> Point-invertViewPort-	ViewPort	{ viewPortScale		= scale-			, viewPortTranslate	= trans-			, viewPortRotate	= rotate }-        pos-	= rotateV (degToRad rotate) (mulSV (1 / scale) pos) - trans-

@@ -1,8 +0,0 @@--module Graphics.Gloss.Geometry-	( module Graphics.Gloss.Geometry.Angle-	, module Graphics.Gloss.Geometry.Line )-where-import Graphics.Gloss.Geometry.Angle-import Graphics.Gloss.Geometry.Line-	

@@ -1,25 +0,0 @@--- | Geometric functions concerning angles. If not otherwise specified, all angles are in radians.-module Graphics.Gloss.Geometry.Angle-	( degToRad-	, radToDeg-	, normaliseAngle )-where---- | Convert degrees to radians-{-# INLINE degToRad #-}-degToRad :: Float -> Float-degToRad d	= d * pi / 180----- | Convert radians to degrees-{-# INLINE radToDeg #-}-radToDeg :: Float -> Float-radToDeg r	= r * 180 / pi----- | Normalise an angle to be between 0 and 2*pi radians-{-# INLINE normaliseAngle #-}-normaliseAngle :: Float -> Float-normaliseAngle f = f - 2 * pi * floor' (f / (2 * pi))- where  floor' :: Float -> Float-        floor' x = fromIntegral (floor x :: Int)

@@ -1,326 +0,0 @@-{-# LANGUAGE PatternGuards #-}---- | Geometric functions concerning lines and segments.------   A @Line@ is taken to be infinite in length, while a @Seg@ is finite length---   line segment represented by its two endpoints. -module Graphics.Gloss.Geometry.Line-	( segClearsBox--	-	-- * Closest points-	, closestPointOnLine-	, closestPointOnLineParam --	-- * Line-Line intersection-	, intersectLineLine--	-- * Seg-Line intersection-	, intersectSegLine-	, intersectSegHorzLine-	, intersectSegVertLine--	-- * Seg-Seg intersection-	, intersectSegSeg-	, intersectSegHorzSeg-	, intersectSegVertSeg)-	-where-import Graphics.Gloss.Data.Point-import Graphics.Gloss.Data.Vector----- | 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--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----- | Given an infinite line which intersects `P1` and `P1`,---	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`--{-# INLINE closestPointOnLine #-}--closestPointOnLine 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.------	Return an indication of where on the line P4 is relative to P1 and P2.------ @---      if P4 == P1 then 0---      if P4 == P2 then 1---      if P4 is halfway between P1 and P2 then 0.5--- @------ @---        |---       P1---        | ---     P4 +---- P3      ---        |---       P2---        |--- @----{-# INLINE closestPointOnLineParam #-}-closestPointOnLineParam-	:: Point 	-- ^ `P1`-	-> Point 	-- ^ `P2`-	-> Point 	-- ^ `P3`-	-> Float--closestPointOnLineParam p1 p2 p3- 	= (p3 - p1) `dotV` (p2 - p1) - 	/ (p2 - p1) `dotV` (p2 - p1)------ Line-Line intersection --------------------------------------------------------- | Given four points specifying two lines, get the point where the two lines---   cross, if any. Note that the lines extend off to infinity, so the---   intersection point might not line between either of the two pairs of points.------ @---     \\      /---      P1  P4---       \\ /---        +---       / \\---      P3  P2---     /     \\--- @----intersectLineLine -	:: 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--	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	--		numx	= det12 * dx34 - dx12 * det34-		numy	= det12 * dy34 - dy12 * det34-	     in	Just (numx / den, numy / den)----- Segment-Line intersection ----------------------------------------------------- | Get the point where a segment @P1-P2@ crosses an infinite line @P3-P4@,---   if any.----intersectSegLine-	:: 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-	---- | Get the point where a segment crosses a horizontal line, if any.------ @ ---                + P1---               /---       -------+------------             /        y0---         P2 +--- @----intersectSegHorzLine -	:: 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)------ | Get the point where a segment crosses a vertical line, if any.------ @---              |---              |   + P1---              | /---              +---            / |---       P2 +   |---              | x0--- @----intersectSegVertLine -	:: 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)----- Segment-Segment intersection --------------------------------------------------- | 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--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----- | Check if an arbitrary segment intersects a horizontal segment.------ @---                 + P2---                /--- (xa, y3)  +---+----+ (xb, y3)---              /---          P1 +--- @ --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.-	-intersectSegHorzSeg p1@(x1, y1) p2@(x2, y2) y0 xa xb-	| 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----- | Check if an arbitrary segment intersects a vertical segment.------ @---      (x3, yb) +---               |   + P1---               | /---               +---             / |---        P2 +   |---               + (x3, ya)--- @ --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.--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--

@@ -1,19 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--module Graphics.Gloss.Internals.Color where--import Graphics.Gloss.Data.Color-import qualified Graphics.Rendering.OpenGL.GL		as GL--import Unsafe.Coerce---- | Convert one of our Colors to OpenGL's representation.-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

@@ -0,0 +1,116 @@+{-# 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)++

@@ -0,0 +1,196 @@+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS -fno-warn-orphans #-}++-- | Data types for representing pictures.+module Graphics.Gloss.Internals.Data.Picture+	( Point+	, Vector+	, Path+	, Picture(..)++        -- * Bitmaps+        , BitmapData+        , 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+        --  between frames for speed. If you are programatically generating+        --  the image for each frame then use `False`. If you have loaded it+        --  from a file then use `True`.+	| Bitmap	Int	Int 	BitmapData Bool++	-- Color ------------------------------------------+	-- | 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 -> ForeignPtr Word8 -> Bool -> Picture+bitmapOfForeignPtr width height fptr cacheMe+ = let  len     = width * height * 4+        bdata   = BitmapData len 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`.+{-# NOINLINE bitmapOfByteString #-}+bitmapOfByteString :: Int -> Int -> ByteString -> Bool -> Picture+bitmapOfByteString width height 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 fptr+        return $ Bitmap width height bdata cacheMe+++-- | O(size). Copy a `BMP` file into a bitmap.+{-# NOINLINE bitmapOfBMP #-}+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 fptr+        reverseRGBA bdata++        return $ Bitmap width height bdata True+++-- | 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++

@@ -1,86 +0,0 @@-{-# OPTIONS -fwarn-incomplete-patterns #-}---- | Helper functions for rendering bitmaps-module Graphics.Gloss.Internals.Render.Bitmap-	( BitmapData(..)-	, reverseRGBA-	, bitmapPath-	, freeBitmapData-	)-where-import Data.Data-import Foreign----- | Abstract 32-bit RGBA bitmap data.-data BitmapData -        = BitmapData -                Int                     -- length (in bytes)-                (ForeignPtr Word8)      -- pointer to data-        deriving (Eq, Data, Typeable)---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----- | Destructively reverse the byte order in an array.---   This is necessary as OpenGL reads pixel data as ABGR, rather than RGBA-reverseRGBA :: BitmapData -> IO ()-reverseRGBA (BitmapData length8 fptr)- = withForeignPtr fptr (reverseRGBA_ptr length8)----- | Destructively reverses the byte order in an array.-reverseRGBA_ptr :: Int -> Ptr Word8 -> IO ()-reverseRGBA_ptr length8 ptr8- = go (length8 `div` 4) (castPtr ptr8) 0- where-        go :: Int -> Ptr Word32 -> Int -> IO ()-        go len ptr count-         | count < len -         = do	curr <- peekElemOff ptr count-      	        let byte0 = shift (isolateByte0 curr) 24-      	        let byte1 = shift (isolateByte1 curr) 8-      	        let byte2 = shift (isolateByte2 curr) (-8)-      	        let byte3 = shift (isolateByte3 curr) (-24)-      	        pokeElemOff ptr count (byte0 .|. byte1 .|. byte2 .|. byte3)-      	        go len ptr (count + 1)--         | otherwise -         = return ()---- | Frees the allocated memory given to OpenGL to avoid a memory leak-freeBitmapData :: Ptr Word8 -> IO ()-{-# INLINE freeBitmapData #-}-freeBitmapData p = free p----- | These functions work as bit masks to isolate the Word8 components-{-# INLINE isolateByte0 #-}-isolateByte0 :: Word32 -> Word32-isolateByte0 word =-   word .&. (255 :: Word32)--{-# INLINE isolateByte1 #-}-isolateByte1 :: Word32 -> Word32-isolateByte1 word =-   word .&. (65280 :: Word32)--{-# INLINE isolateByte2 #-}-isolateByte2 :: Word32 -> Word32-isolateByte2 word =-   word .&. (16711680 :: Word32)--{-# INLINE isolateByte3 #-}-isolateByte3 :: Word32 -> Word32-isolateByte3 word =-   word .&. (4278190080 :: Word32)

@@ -1,246 +0,0 @@-{-# LANGUAGE BangPatterns, MagicHash, PatternGuards #-}-{-# OPTIONS_HADDOCK hide #-}---- | Fast(ish) rendering of circles.-module Graphics.Gloss.Internals.Render.Circle-        ( renderCircle-        , renderArc)-where-import 	Graphics.Gloss.Internals.Render.Common-import  Graphics.Gloss.Geometry.Angle-import	qualified Graphics.Rendering.OpenGL.GL		as GL-import	GHC.Exts----- | Decide how many line segments to use to render the circle.---   The number of segments we should use to get a nice picture depends on ---   the size of the circle on the screen, not its intrinsic radius.---   If the viewport has been zoomed-in then we need to use more segments.----{-# INLINE circleSteps #-}-circleSteps :: Float -> Int-circleSteps sDiam-        | sDiam < 8     = 8-        | sDiam < 16    = 16-        | sDiam < 32    = 32-        | otherwise     = 64----- 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              = normaliseAngle $ degToRad a1-        t2              = normaliseAngle $ degToRad a2-        (tStart, tStop) = if t1 <= t2 then (t1, t2) else (t2, t1)-        tDiff           = tStop - tStart-        tMid            = tStart + tDiff / 2-- 	!(F# tStep')	= tStep-        !(F# tStep2')   = tStep / 2-        !(F# tStart')   = tStart-        !(F# tStop')    = tStop-        !(F# tCut')     = tStop - tStep-        !(F# tMid')     = tMid-	!(F# r1')	= r - width / 2-	!(F# r2')	= r + width / 2-                -   in	GL.renderPrimitive GL.TriangleStrip-   	 $ 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 #-}----{- 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--}-

@@ -1,50 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}-module Graphics.Gloss.Internals.Render.Common where--import	Graphics.Rendering.OpenGL	       (($=))-import qualified Graphics.Rendering.OpenGL.GL	as GL-import Unsafe.Coerce----- | 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-{-# INLINE gf #-}-gf x = unsafeCoerce x----- | Used for similar reasons to above-gsizei :: Int -> GL.GLsizei-{-# INLINE gsizei #-}-gsizei x = unsafeCoerce x----- | Perform an OpenGL rendering action in the appropriate @ModelView@ context.-renderAction-	:: (Int, Int)  -- ^ Width and height of window.-	-> IO ()       -- ^ Action to perform.-	-> IO ()--renderAction (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

@@ -1,376 +0,0 @@-{-# OPTIONS -fwarn-incomplete-patterns #-}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE ImplicitParams, ScopedTypeVariables #-}--module Graphics.Gloss.Internals.Render.Picture-	(renderPicture)-where-import Graphics.Gloss.Data.Picture-import Graphics.Gloss.Data.Color-import Graphics.Gloss.Data.ViewPort-import Graphics.Gloss.Internals.Render.State-import Graphics.Gloss.Internals.Render.Common-import Graphics.Gloss.Internals.Render.Circle-import Graphics.Gloss.Internals.Render.Bitmap-import System.Mem.StableName-import Foreign.ForeignPtr-import Data.IORef-import Data.List-import Control.Monad-import Graphics.Rendering.OpenGL	               	(($=), get)-import qualified Graphics.Rendering.OpenGL.GL	        as GL-import qualified Graphics.Rendering.OpenGL.GLU.Errors   as GLU-import qualified Graphics.UI.GLUT		        as GLUT----- | Render a picture using the given render state and viewport.-renderPicture-	:: State		-- ^ Current rendering state.-	-> ViewPort		-- ^ Current viewport.-	-> Picture 		-- ^ Picture to render.-	-> IO ()--renderPicture-	renderS-	viewPort-	picture- = do-	-- This GL state doesn't change during rendering, -	--	so we can just read it once here-	(matProj_  :: GL.GLmatrix GL.GLdouble)	-			<- get $ GL.matrix (Just GL.Projection)-	viewport_  	<- get $ GL.viewport--	-- -	let ?modeWireframe	= stateWireframe renderS-	    ?modeColor		= stateColor     renderS-	    ?refTextures        = stateTextures  renderS-	    ?matProj		= matProj_-	    ?viewport		= viewport_-	-	-- setup render state for world-	setLineSmooth	(stateLineSmooth renderS)-	setBlendAlpha	(stateBlendAlpha renderS)-	-	-- Adjust the picture-	let picture'		= applyViewPortToPicture viewPort picture-        checkErrors "before drawPicture."-        drawPicture (viewPortScale viewPort) picture'-        checkErrors "after drawPicture."---drawPicture-	:: ( ?modeWireframe     :: Bool-	   , ?modeColor         :: Bool-	   , ?refTextures       :: IORef [Texture])-	=> Float -> Picture -> IO ()	  --drawPicture circScale picture- = {-# SCC "drawComponent" #-}-   case picture of--	-- nothin'-	Blank-	 -> 	return ()--	-- line- 	Line path	-	 -> GL.renderPrimitive GL.LineStrip -		$ vertexPFs path---	-- polygon (where?)-	Polygon path-	 | ?modeWireframe-	 -> 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-	 |  ?modeColor-	 ->  do	oldColor 	 <- get GL.currentColor--		let (r, g, b, a) = rgbaOfColor col--		GL.currentColor	 $= GL.Color4 (gf r) (gf g) (gf b) (gf a)-		drawPicture circScale p-		GL.currentColor	$= oldColor		--	 |  otherwise-	 -> 	drawPicture 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 circScale p--	Translate tx ty	p-	 -> GL.preservingMatrix-	  $ do	GL.translate (GL.Vector3 (gf tx) (gf ty) 0)-		drawPicture circScale p---        -- Rotation ------------------------------        -- Easy rotations are done directly to avoid calling GL.perserveMatrix.-        Rotate _   (Circle radius)-         -> renderCircle   0 0 circScale radius 0--        Rotate _   (ThickCircle radius thickness)-         -> renderCircle   0 0 circScale radius thickness--        Rotate deg (Arc a1 a2 radius)-         -> renderArc      0 0 circScale radius (a1-deg) (a2-deg) 0--        Rotate deg (ThickArc a1 a2 radius thickness)-         -> renderArc      0 0 circScale radius (a1-deg) (a2-deg) thickness--        -	Rotate deg p-	 -> GL.preservingMatrix-	  $ do	GL.rotate (gf deg) (GL.Vector3 0 0 (-1))-		drawPicture circScale p---        -- Scale ---------------------------------	Scale sx sy p-	 -> GL.preservingMatrix-	  $ do	GL.scale (gf sx) (gf sy) 1-		let mscale	= max sx sy-		drawPicture (circScale * mscale) p-			-	-- Bitmap --------------------------------	Bitmap width height imgData cacheMe-	 -> do	-                -- Load the image data into a texture,-                -- or grab it from the cache if we've already done that before.-	        tex     <- loadTexture ?refTextures 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-		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))-			        [(0,0), (1.0,0), (1.0,1.0), (0,1.0)]--		-- Disable texturing-		GL.texture GL.Texture2D $= GL.Disabled--                -- Free uncachable texture objects.-                freeTexture tex-                --	Pictures ps-	 -> mapM_ (drawPicture 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 _ fptr) cacheMe- = do   -	-- 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 GL.RGBA 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 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 ()-{-# INLINE vertexPFs #-}-vertexPFs []	= return ()-vertexPFs ((x, y) : rest)- = do	GL.vertex $ GL.Vertex2 (gf x) (gf y)- 	vertexPFs rest---

@@ -1,70 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}---- | Rendering options-module Graphics.Gloss.Internals.Render.State-	( State (..)-	, stateInit-	, Texture (..))-where-import qualified Graphics.Rendering.OpenGL.GL	as GL-import Foreign.ForeignPtr-import System.Mem.StableName-import Data.Word-import Data.IORef-import Graphics.Gloss.Data.Picture---- | Render options settings-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 }----- | The render state holds references to the textures currently cached---   in the OpenGL context.-stateInit :: IO State-stateInit- = do   textures        <- newIORef []-	return  State-	        { stateColor		= True-                , stateWireframe	= False-	        , stateBlendAlpha	= True-	        , stateLineSmooth	= False -	        , stateTextures         = textures }-	-

@@ -0,0 +1,86 @@+{-# OPTIONS_HADDOCK hide #-}++-- | Helper functions for rendering bitmaps+module Graphics.Gloss.Internals.Rendering.Bitmap+	( BitmapData(..)+	, reverseRGBA+	, bitmapPath+	, freeBitmapData+	)+where+import Data.Data+import Foreign+++-- | Abstract 32-bit RGBA bitmap data.+data BitmapData +        = BitmapData +                Int                     -- length (in bytes)+                (ForeignPtr Word8)      -- pointer to data+        deriving (Eq, Data, Typeable)+++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+++-- | Destructively reverse the byte order in an array.+--   This is necessary as OpenGL reads pixel data as ABGR, rather than RGBA+reverseRGBA :: BitmapData -> IO ()+reverseRGBA (BitmapData length8 fptr)+ = withForeignPtr fptr (reverseRGBA_ptr length8)+++-- | Destructively reverses the byte order in an array.+reverseRGBA_ptr :: Int -> Ptr Word8 -> IO ()+reverseRGBA_ptr length8 ptr8+ = go (length8 `div` 4) (castPtr ptr8) 0+ where+        go :: Int -> Ptr Word32 -> Int -> IO ()+        go len ptr count+         | count < len +         = do	curr <- peekElemOff ptr count+      	        let byte0 = shift (isolateByte0 curr) 24+      	        let byte1 = shift (isolateByte1 curr) 8+      	        let byte2 = shift (isolateByte2 curr) (-8)+      	        let byte3 = shift (isolateByte3 curr) (-24)+      	        pokeElemOff ptr count (byte0 .|. byte1 .|. byte2 .|. byte3)+      	        go len ptr (count + 1)++         | otherwise +         = return ()++-- | Frees the allocated memory given to OpenGL to avoid a memory leak+freeBitmapData :: Ptr Word8 -> IO ()+{-# INLINE freeBitmapData #-}+freeBitmapData p = free p+++-- | These functions work as bit masks to isolate the Word8 components+{-# INLINE isolateByte0 #-}+isolateByte0 :: Word32 -> Word32+isolateByte0 word =+   word .&. (255 :: Word32)++{-# INLINE isolateByte1 #-}+isolateByte1 :: Word32 -> Word32+isolateByte1 word =+   word .&. (65280 :: Word32)++{-# INLINE isolateByte2 #-}+isolateByte2 :: Word32 -> Word32+isolateByte2 word =+   word .&. (16711680 :: Word32)++{-# INLINE isolateByte3 #-}+isolateByte3 :: Word32 -> Word32+isolateByte3 word =+   word .&. (4278190080 :: Word32)

@@ -0,0 +1,257 @@+{-# 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.+--+{-# INLINE circleSteps #-}+circleSteps :: Float -> Int+circleSteps sDiam+        | sDiam < 8     = 8+        | sDiam < 16    = 16+        | sDiam < 32    = 32+        | otherwise     = 64+++-- 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+-}+

@@ -0,0 +1,19 @@+{-# 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 :: Fractional a => 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 #-}

@@ -0,0 +1,80 @@+{-# 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+

@@ -0,0 +1,355 @@+{-# 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	+                -- 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+		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))+			        [(0,0), (1.0,0), (1.0,1.0), (0,1.0)]++		-- 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 _ fptr) cacheMe+ = do   +	-- 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 GL.RGBA 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 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 ()+{-# INLINE vertexPFs #-}+vertexPFs []	= return ()+vertexPFs ((x, y) : rest)+ = do	GL.vertex $ GL.Vertex2 (gf x) (gf y)+ 	vertexPFs rest+++

@@ -0,0 +1,72 @@+{-# 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+++-- | Render options settings+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 }+	+

@@ -1,46 +0,0 @@-module Graphics.Gloss.Render -        ( render-        , renderAction-        , renderPicture-        , RS.stateInit)-where-import qualified Graphics.Rendering.OpenGL as GL-import Graphics.Gloss.Internals.Render.Common-import Graphics.Gloss.Internals.Render.Picture-import Graphics.Gloss.Internals.Color-import Graphics.Gloss.Data.Color-import Graphics.Gloss.Data.Picture-import Graphics.Gloss.Data.ViewPort-import qualified Graphics.Gloss.Internals.Render.State as RS-import System.Mem (performGC)----- | Clear the current OpenGL context and draw the given picture into it. The---   mutable state holds references to the textures currently loaded into the---   context, and may have new ones added to it when drawing the picture.-render  :: RS.State     -- ^ Current rendering state.-        -> (Int, Int)   -- ^ Window width and height.-        -> Color        -- ^ Color to clear the window with.-        -> Picture      -- ^ Picture to draw.-        -> IO ()--render renderS windowSize clearColor picture-  = do -        let viewPort = viewPortInit--        -- 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)--        renderAction-              windowSize-              (renderPicture renderS viewPort picture) --        performGC

@@ -0,0 +1,60 @@++module Graphics.Gloss.Rendering +        ( -- * Picture data type+          Picture (..)+        , Point, Vector, Path++          -- * Colors+        , Color+        , makeColor+        , makeColorI+        , makeRawColor+        , makeRawColorI+        , rgbaOfColor+        , clampColor++          -- * Bitmaps+        , BitmapData+        , bitmapOfForeignPtr+        , bitmapOfByteString+        , bitmapOfBMP+        , loadBMP++          -- * Rendering+        , displayPicture+        , renderPicture+        , withModelview+        , withClearBuffer+        , RS.initState)++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

@@ -1,5 +1,5 @@ name:           gloss-rendering-version:        1.9.1.1+version:        1.9.2.1 license:        MIT license-file:   LICENSE author:         Elise Huard@@ -7,32 +7,25 @@ category:       Graphics build-type:     Simple cabal-version:  >=1.10-synopsis:       Gloss Picture data type and rendering functions.     -description:    Gloss Picture data type and rendering functions.+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.Render-        Graphics.Gloss.Internals.Render.State-        Graphics.Gloss.Geometry-        Graphics.Gloss.Geometry.Angle-        Graphics.Gloss.Geometry.Line-        Graphics.Gloss.Data.Display-        Graphics.Gloss.Data.Point-        Graphics.Gloss.Data.Vector-        Graphics.Gloss.Data.Quad-        Graphics.Gloss.Data.Extent-        Graphics.Gloss.Data.QuadTree-        Graphics.Gloss.Data.Color-        Graphics.Gloss.Internals.Color-        Graphics.Gloss.Data.Picture-        Graphics.Gloss.Data.ViewPort+        Graphics.Gloss.Rendering    other-modules:       -        Graphics.Gloss.Internals.Render.Common-        Graphics.Gloss.Internals.Render.Picture-        Graphics.Gloss.Internals.Render.Circle-        Graphics.Gloss.Internals.Render.Bitmap+        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.7.*,@@ -49,4 +42,8 @@         Haskell2010    default-extensions:    +        BangPatterns+        MagicHash+        TypeSynonymInstances+        FlexibleInstances         DeriveDataTypeable