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
renderPicture
:: State
-> ViewPort
-> Picture
-> IO ()
renderPicture
renderS
viewPort
picture
= do
(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_
setLineSmooth (stateLineSmooth renderS)
setBlendAlpha (stateBlendAlpha renderS)
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
=
case picture of
Blank
-> return ()
Line path
-> GL.renderPrimitive GL.LineStrip
$ vertexPFs path
Polygon path
| ?modeWireframe
-> GL.renderPrimitive GL.LineLoop
$ vertexPFs path
| otherwise
-> GL.renderPrimitive GL.Polygon
$ vertexPFs path
Circle radius
-> renderCircle 0 0 circScale radius 0
ThickCircle radius thickness
-> renderCircle 0 0 circScale radius thickness
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
Text str
-> do
GL.blend $= GL.Disabled
GL.preservingMatrix $ GLUT.renderString GLUT.Roman str
GL.blend $= GL.Enabled
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
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
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 (a1deg) (a2deg) 0
Rotate deg (ThickArc a1 a2 radius thickness)
-> renderArc 0 0 circScale radius (a1deg) (a2deg) thickness
Rotate deg p
-> GL.preservingMatrix
$ do GL.rotate (gf deg) (GL.Vector3 0 0 (1))
drawPicture circScale p
Scale sx sy p
-> GL.preservingMatrix
$ do GL.scale (gf sx) (gf sy) 1
let mscale = max sx sy
drawPicture (circScale * mscale) p
Bitmap width height imgData cacheMe
-> do
tex <- loadTexture ?refTextures width height imgData cacheMe
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)
GL.texture GL.Texture2D $= GL.Enabled
GL.textureFunction $= GL.Combine
GL.textureBinding GL.Texture2D $= Just (texObject tex)
GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0
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)]
GL.texture GL.Texture2D $= GL.Disabled
freeTexture tex
Pictures ps
-> mapM_ (drawPicture circScale) ps
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." ]
GLU.Error GLU.InvalidOperation _
-> return ()
_
-> error $ unlines
[ "Gloss / OpenGL Internal Error " ++ show place
, " Please report this on haskell-gloss@googlegroups.com."
, show err ]
loadTexture
:: IORef [Texture]
-> Int -> Int -> BitmapData
-> Bool
-> IO Texture
loadTexture refTextures width height imgData cacheMe
= do textures <- readIORef refTextures
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
installTexture
:: Int -> Int
-> BitmapData
-> Bool
-> IO Texture
installTexture width height bitmapData@(BitmapData _ fptr) cacheMe
= do
[tex] <- GL.genObjectNames 1
GL.textureBinding GL.Texture2D $= Just tex
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)
name <- makeStableName bitmapData
return Texture
{ texName = name
, texWidth = width
, texHeight = height
, texData = fptr
, texObject = tex
, texCacheMe = cacheMe }
freeTexture :: Texture -> IO ()
freeTexture tex
| texCacheMe tex = return ()
| otherwise = GL.deleteObjectNames [texObject tex]
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)
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