gloss-rendering (empty) → 1.9.1.1
raw patch · 22 files changed
+2522/−0 lines, 22 filesdep +GLUTdep +OpenGLdep +basesetup-changed
Dependencies added: GLUT, OpenGL, base, bmp, bytestring, containers
Files
- Graphics/Gloss/Data/Color.hs +237/−0
- Graphics/Gloss/Data/Display.hs +13/−0
- Graphics/Gloss/Data/Extent.hs +195/−0
- Graphics/Gloss/Data/Picture.hs +351/−0
- Graphics/Gloss/Data/Point.hs +51/−0
- Graphics/Gloss/Data/Quad.hs +17/−0
- Graphics/Gloss/Data/QuadTree.hs +191/−0
- Graphics/Gloss/Data/Vector.hs +91/−0
- Graphics/Gloss/Data/ViewPort.hs +57/−0
- Graphics/Gloss/Geometry.hs +8/−0
- Graphics/Gloss/Geometry/Angle.hs +25/−0
- Graphics/Gloss/Geometry/Line.hs +326/−0
- Graphics/Gloss/Internals/Color.hs +19/−0
- Graphics/Gloss/Internals/Render/Bitmap.hs +86/−0
- Graphics/Gloss/Internals/Render/Circle.hs +246/−0
- Graphics/Gloss/Internals/Render/Common.hs +50/−0
- Graphics/Gloss/Internals/Render/Picture.hs +376/−0
- Graphics/Gloss/Internals/Render/State.hs +70/−0
- Graphics/Gloss/Render.hs +46/−0
- LICENSE +13/−0
- Setup.hs +2/−0
- gloss-rendering.cabal +52/−0
+ Graphics/Gloss/Data/Color.hs view
@@ -0,0 +1,237 @@++-- | 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
+ Graphics/Gloss/Data/Display.hs view
@@ -0,0 +1,13 @@++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)
+ Graphics/Gloss/Data/Extent.hs view
@@ -0,0 +1,195 @@+{-# 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)+
+ Graphics/Gloss/Data/Picture.hs view
@@ -0,0 +1,351 @@++-- | 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+
+ Graphics/Gloss/Data/Point.hs view
@@ -0,0 +1,51 @@+{-# 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
+ Graphics/Gloss/Data/Quad.hs view
@@ -0,0 +1,17 @@++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]
+ Graphics/Gloss/Data/QuadTree.hs view
@@ -0,0 +1,191 @@+{-# 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'++
+ Graphics/Gloss/Data/Vector.hs view
@@ -0,0 +1,91 @@+{-# 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 #-}+
+ Graphics/Gloss/Data/ViewPort.hs view
@@ -0,0 +1,57 @@+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+
+ Graphics/Gloss/Geometry.hs view
@@ -0,0 +1,8 @@++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+
+ Graphics/Gloss/Geometry/Angle.hs view
@@ -0,0 +1,25 @@+-- | 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)
+ Graphics/Gloss/Geometry/Line.hs view
@@ -0,0 +1,326 @@+{-# 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++
+ Graphics/Gloss/Internals/Color.hs view
@@ -0,0 +1,19 @@+{-# 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
+ Graphics/Gloss/Internals/Render/Bitmap.hs view
@@ -0,0 +1,86 @@+{-# 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)
+ Graphics/Gloss/Internals/Render/Circle.hs view
@@ -0,0 +1,246 @@+{-# 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+-}+
+ Graphics/Gloss/Internals/Render/Common.hs view
@@ -0,0 +1,50 @@+{-# 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
+ Graphics/Gloss/Internals/Render/Picture.hs view
@@ -0,0 +1,376 @@+{-# 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+++
+ Graphics/Gloss/Internals/Render/State.hs view
@@ -0,0 +1,70 @@+{-# 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 }+ +
+ Graphics/Gloss/Render.hs view
@@ -0,0 +1,46 @@+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
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright (c) 2010-2014 Benjamin Lippmeier ++ Permission is hereby granted, free of charge, to any person+ obtaining a copy of this software and associated documentation+ files (the "Software"), to deal in the Software without+ restriction, including without limitation the rights to use,+ copy, modify, merge, publish, distribute, sublicense, and/or sell+ copies of the Software, and to permit persons to whom the+ Software is furnished to do so, subject to the following+ condition:++ The above copyright notice and this permission notice shall be+ included in all copies or substantial portions of the Software.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gloss-rendering.cabal view
@@ -0,0 +1,52 @@+name: gloss-rendering+version: 1.9.1.1+license: MIT+license-file: LICENSE+author: Elise Huard+maintainer: elise@jabberwocky.eu benl@ouroborus.net+category: Graphics+build-type: Simple+cabal-version: >=1.10+synopsis: Gloss Picture data type and rendering functions. +description: Gloss Picture data type and rendering functions.++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++ other-modules: + Graphics.Gloss.Internals.Render.Common+ Graphics.Gloss.Internals.Render.Picture+ Graphics.Gloss.Internals.Render.Circle+ Graphics.Gloss.Internals.Render.Bitmap++ build-depends: + base == 4.7.*,+ containers == 0.5.*,+ bytestring == 0.10.*,+ OpenGL == 2.9.*,+ GLUT == 2.5.*,+ bmp == 1.2.*++ ghc-options:+ -Wall++ default-language: + Haskell2010++ default-extensions: + DeriveDataTypeable