gloss-rendering-1.12.0.0: Graphics/Gloss/Internals/Rendering/Picture.hs
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_HADDOCK hide #-}
module Graphics.Gloss.Internals.Rendering.Picture
(renderPicture)
where
import Graphics.Gloss.Internals.Rendering.State
import Graphics.Gloss.Internals.Rendering.Common
import Graphics.Gloss.Internals.Rendering.Circle
import Graphics.Gloss.Internals.Rendering.Bitmap
import Graphics.Gloss.Internals.Data.Picture
import Graphics.Gloss.Internals.Data.Color
import System.Mem.StableName
import Foreign.ForeignPtr
import Data.IORef
import Data.List
import Control.Monad
import Graphics.Rendering.OpenGL (($=), get)
import qualified Graphics.Rendering.OpenGL.GL as GL
import qualified Graphics.Rendering.OpenGL.GLU.Errors as GLU
import qualified Graphics.UI.GLUT as GLUT
-- | Render a picture into the current OpenGL context.
--
-- Assumes that the OpenGL matrix mode is set to @Modelview@
--
renderPicture
:: State -- ^ Current rendering state.
-> Float -- ^ View port scale, which controls the level of detail.
-- Use 1.0 to start with.
-> Picture -- ^ Picture to render.
-> IO ()
renderPicture state circScale picture
= do
-- Setup render state for world
setLineSmooth (stateLineSmooth state)
setBlendAlpha (stateBlendAlpha state)
-- Draw the picture
checkErrors "before drawPicture."
drawPicture state circScale picture
checkErrors "after drawPicture."
drawPicture :: State -> Float -> Picture -> IO ()
drawPicture state circScale picture
= {-# SCC "drawComponent" #-}
case picture of
-- nothin'
Blank
-> return ()
-- line
Line path
-> GL.renderPrimitive GL.LineStrip
$ vertexPFs path
-- polygon (where?)
Polygon path
| stateWireframe state
-> GL.renderPrimitive GL.LineLoop
$ vertexPFs path
| otherwise
-> GL.renderPrimitive GL.Polygon
$ vertexPFs path
-- circle
Circle radius
-> renderCircle 0 0 circScale radius 0
ThickCircle radius thickness
-> renderCircle 0 0 circScale radius thickness
-- arc
Arc a1 a2 radius
-> renderArc 0 0 circScale radius a1 a2 0
ThickArc a1 a2 radius thickness
-> renderArc 0 0 circScale radius a1 a2 thickness
-- stroke text
-- text looks weird when we've got blend on,
-- so disable it during the renderString call.
Text str
-> do
GL.blend $= GL.Disabled
GL.preservingMatrix $ GLUT.renderString GLUT.Roman str
GL.blend $= GL.Enabled
-- colors with float components.
Color col p
| stateColor state
-> do oldColor <- get GL.currentColor
let RGBA r g b a = col
GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a)
drawPicture state circScale p
GL.currentColor $= oldColor
| otherwise
-> drawPicture state circScale p
-- Translation --------------------------
-- Easy translations are done directly to avoid calling GL.perserveMatrix.
Translate posX posY (Circle radius)
-> renderCircle posX posY circScale radius 0
Translate posX posY (ThickCircle radius thickness)
-> renderCircle posX posY circScale radius thickness
Translate posX posY (Arc a1 a2 radius)
-> renderArc posX posY circScale radius a1 a2 0
Translate posX posY (ThickArc a1 a2 radius thickness)
-> renderArc posX posY circScale radius a1 a2 thickness
Translate tx ty (Rotate deg p)
-> GL.preservingMatrix
$ do GL.translate (GL.Vector3 (gf tx) (gf ty) 0)
GL.rotate (gf deg) (GL.Vector3 0 0 (-1))
drawPicture state circScale p
Translate tx ty p
-> GL.preservingMatrix
$ do GL.translate (GL.Vector3 (gf tx) (gf ty) 0)
drawPicture state circScale p
-- Rotation -----------------------------
-- Easy rotations are done directly to avoid calling GL.perserveMatrix.
Rotate _ (Circle radius)
-> renderCircle 0 0 circScale radius 0
Rotate _ (ThickCircle radius thickness)
-> renderCircle 0 0 circScale radius thickness
Rotate deg (Arc a1 a2 radius)
-> renderArc 0 0 circScale radius (a1-deg) (a2-deg) 0
Rotate deg (ThickArc a1 a2 radius thickness)
-> renderArc 0 0 circScale radius (a1-deg) (a2-deg) thickness
Rotate deg p
-> GL.preservingMatrix
$ do GL.rotate (gf deg) (GL.Vector3 0 0 (-1))
drawPicture state circScale p
-- Scale --------------------------------
Scale sx sy p
-> GL.preservingMatrix
$ do GL.scale (gf sx) (gf sy) 1
let mscale = max sx sy
drawPicture state (circScale * mscale) p
-- Bitmap -------------------------------
Bitmap width height imgData cacheMe
-> do
let rowInfo =
case rowOrder (bitmapFormat imgData) of
BottomToTop -> [(0,0), (1,0), (1,1), (0,1)]
TopToBottom -> [(0,1), (1,1), (1,0), (0,0)]
-- Load the image data into a texture,
-- or grab it from the cache if we've already done that before.
tex <- loadTexture (stateTextures state) width height imgData cacheMe
-- Set up wrap and filtering mode
GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat)
GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat)
GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)
-- Enable texturing
GL.texture GL.Texture2D $= GL.Enabled
GL.textureFunction $= GL.Combine
-- Set current texture
GL.textureBinding GL.Texture2D $= Just (texObject tex)
-- Set to opaque
oldColor <- get GL.currentColor
GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0
-- Draw textured polygon
GL.renderPrimitive GL.Polygon
$ zipWithM_
(\(pX, pY) (tX, tY)
-> do GL.texCoord $ GL.TexCoord2 (gf tX) (gf tY)
GL.vertex $ GL.Vertex2 (gf pX) (gf pY))
(bitmapPath (fromIntegral width) (fromIntegral height))
rowInfo
-- Restore color
GL.currentColor $= oldColor
-- Disable texturing
GL.texture GL.Texture2D $= GL.Disabled
-- Free uncachable texture objects.
freeTexture tex
Pictures ps
-> mapM_ (drawPicture state circScale) ps
-- Errors ---------------------------------------------------------------------
checkErrors :: String -> IO ()
checkErrors place
= do errors <- get $ GLU.errors
when (not $ null errors)
$ mapM_ (handleError place) errors
handleError :: String -> GLU.Error -> IO ()
handleError place err
= case err of
GLU.Error GLU.StackOverflow _
-> error $ unlines
[ "Gloss / OpenGL Stack Overflow " ++ show place
, " This program uses the Gloss vector graphics library, which tried to"
, " draw a picture using more nested transforms (Translate/Rotate/Scale)"
, " than your OpenGL implementation supports. The OpenGL spec requires"
, " all implementations to have a transform stack depth of at least 32,"
, " and Gloss tries not to push the stack when it doesn't have to, but"
, " that still wasn't enough."
, ""
, " You should complain to your harware vendor that they don't provide"
, " a better way to handle this situation at the OpenGL API level."
, ""
, " To make this program work you'll need to reduce the number of nested"
, " transforms used when defining the Picture given to Gloss. Sorry." ]
-- Issue #32: Spurious "Invalid Operation" errors under Windows 7 64-bit.
-- When using GLUT under Windows 7 it complains about InvalidOperation,
-- but doesn't provide any other details. All the examples look ok, so
-- we're just ignoring the error for now.
GLU.Error GLU.InvalidOperation _
-> return ()
_
-> error $ unlines
[ "Gloss / OpenGL Internal Error " ++ show place
, " Please report this on haskell-gloss@googlegroups.com."
, show err ]
-- Textures -------------------------------------------------------------------
-- | Load a texture.
-- If we've seen it before then use the pre-installed one from the texture
-- cache, otherwise load it into OpenGL.
loadTexture
:: IORef [Texture]
-> Int -> Int -> BitmapData
-> Bool
-> IO Texture
loadTexture refTextures width height imgData cacheMe
= do textures <- readIORef refTextures
-- Try and find this same texture in the cache.
name <- makeStableName imgData
let mTexCached
= find (\tex -> texName tex == name
&& texWidth tex == width
&& texHeight tex == height)
textures
case mTexCached of
Just tex
-> return tex
Nothing
-> do tex <- installTexture width height imgData cacheMe
when cacheMe
$ writeIORef refTextures (tex : textures)
return tex
-- | Install a texture into OpenGL.
installTexture
:: Int -> Int
-> BitmapData
-> Bool
-> IO Texture
installTexture width height bitmapData@(BitmapData _ fmt fptr) cacheMe
= do
let glFormat
= case pixelFormat fmt of
PxABGR -> GL.ABGR
PxRGBA -> GL.RGBA
-- Allocate texture handle for texture
[tex] <- GL.genObjectNames 1
GL.textureBinding GL.Texture2D $= Just tex
-- Sets the texture in imgData as the current texture
-- This copies the data from the pointer into OpenGL texture memory,
-- so it's ok if the foreignptr gets garbage collected after this.
withForeignPtr fptr
$ \ptr ->
GL.texImage2D
GL.Texture2D
GL.NoProxy
0
GL.RGBA8
(GL.TextureSize2D
(gsizei width)
(gsizei height))
0
(GL.PixelData glFormat GL.UnsignedByte ptr)
-- Make a stable name that we can use to identify this data again.
-- If the user gives us the same texture data at the same size then we
-- can avoid loading it into texture memory again.
name <- makeStableName bitmapData
return Texture
{ texName = name
, texWidth = width
, texHeight = height
, texData = fptr
, texObject = tex
, texCacheMe = cacheMe }
-- | If this texture does not have its `cacheMe` flag set then delete it from
-- OpenGL and free the GPU memory.
freeTexture :: Texture -> IO ()
freeTexture tex
| texCacheMe tex = return ()
| otherwise = GL.deleteObjectNames [texObject tex]
-- Utils ----------------------------------------------------------------------
-- | Turn alpha blending on or off
setBlendAlpha :: Bool -> IO ()
setBlendAlpha state
| state
= do GL.blend $= GL.Enabled
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
| otherwise
= do GL.blend $= GL.Disabled
GL.blendFunc $= (GL.One, GL.Zero)
-- | Turn line smoothing on or off
setLineSmooth :: Bool -> IO ()
setLineSmooth state
| state = GL.lineSmooth $= GL.Enabled
| otherwise = GL.lineSmooth $= GL.Disabled
vertexPFs :: [(Float, Float)] -> IO ()
vertexPFs [] = return ()
vertexPFs ((x, y) : rest)
= do GL.vertex $ GL.Vertex2 (gf x) (gf y)
vertexPFs rest
{-# INLINE vertexPFs #-}