{-# 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.Polygon
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 -> GLfloat -> Picture -> IO ()
renderPicture State
state GLfloat
circScale Picture
picture
 = do
        -- Setup render state for world
        Bool -> IO ()
setLineSmooth   (State -> Bool
stateLineSmooth State
state)
        Bool -> IO ()
setBlendAlpha   (State -> Bool
stateBlendAlpha State
state)

        -- Draw the picture
        String -> IO ()
checkErrors String
"before drawPicture."
        State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
picture
        String -> IO ()
checkErrors String
"after drawPicture."


drawPicture :: State -> Float -> Picture -> IO ()
drawPicture :: State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
picture
 = {-# SCC "drawComponent" #-}
   case Picture
picture of

        -- nothin'
        Picture
Blank
         ->     () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        -- line
        Line Path
path
         -> PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.LineStrip
                (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Path -> IO ()
vertexPFs Path
path

        -- polygon (where?)
        Polygon Path
path
         | State -> Bool
stateWireframe State
state
         -> PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.LineLoop
                (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Path -> IO ()
vertexPFs Path
path

         | Bool
otherwise
         -> Path -> IO ()
renderComplexPolygon Path
path

        -- circle
        Circle GLfloat
radius
         ->  GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
0

        ThickCircle GLfloat
radius GLfloat
thickness
         ->  GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
thickness

        -- arc
        Arc GLfloat
a1 GLfloat
a2 GLfloat
radius
         ->  GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
a1 GLfloat
a2 GLfloat
0

        ThickArc GLfloat
a1 GLfloat
a2 GLfloat
radius GLfloat
thickness
         ->  GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
a1 GLfloat
a2 GLfloat
thickness

        -- stroke text
        --      text looks weird when we've got blend on,
        --      so disable it during the renderString call.
        Text String
str
         -> do
                StateVar Capability
GL.blend        StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Disabled
                IO () -> IO ()
forall a. IO a -> IO a
GL.preservingMatrix (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StrokeFont -> String -> IO ()
forall a (m :: * -> *). (Font a, MonadIO m) => a -> String -> m ()
forall (m :: * -> *). MonadIO m => StrokeFont -> String -> m ()
GLUT.renderString StrokeFont
GLUT.Roman String
str
                StateVar Capability
GL.blend        StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Enabled

        -- colors with float components.
        Color Color
col Picture
p
         |  State -> Bool
stateColor State
state
         ->  do oldColor         <- StateVar (Color4 GLfloat) -> IO (Color4 GLfloat)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *).
MonadIO m =>
StateVar (Color4 GLfloat) -> m (Color4 GLfloat)
get StateVar (Color4 GLfloat)
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

         |  Bool
otherwise
         ->     State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
p


        -- Translation --------------------------
        -- Easy translations are done directly to avoid calling GL.perserveMatrix.
        Translate GLfloat
posX GLfloat
posY (Circle GLfloat
radius)
         -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle GLfloat
posX GLfloat
posY GLfloat
circScale GLfloat
radius GLfloat
0

        Translate GLfloat
posX GLfloat
posY (ThickCircle GLfloat
radius GLfloat
thickness)
         -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle GLfloat
posX GLfloat
posY GLfloat
circScale GLfloat
radius GLfloat
thickness

        Translate GLfloat
posX GLfloat
posY (Arc GLfloat
a1 GLfloat
a2 GLfloat
radius)
         -> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc GLfloat
posX GLfloat
posY GLfloat
circScale GLfloat
radius GLfloat
a1 GLfloat
a2 GLfloat
0

        Translate GLfloat
posX GLfloat
posY (ThickArc GLfloat
a1 GLfloat
a2 GLfloat
radius GLfloat
thickness)
         -> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc GLfloat
posX GLfloat
posY GLfloat
circScale GLfloat
radius GLfloat
a1 GLfloat
a2 GLfloat
thickness

        Translate GLfloat
tx GLfloat
ty (Rotate GLfloat
deg Picture
p)
         -> IO () -> IO ()
forall a. IO a -> IO a
GL.preservingMatrix
          (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do  Vector3 GLfloat -> IO ()
forall c. MatrixComponent c => Vector3 c -> IO ()
GL.translate (GLfloat -> GLfloat -> GLfloat -> Vector3 GLfloat
forall a. a -> a -> a -> Vector3 a
GL.Vector3 (GLfloat -> GLfloat
gf GLfloat
tx) (GLfloat -> GLfloat
gf GLfloat
ty) GLfloat
0)
                GLfloat -> Vector3 GLfloat -> IO ()
forall c. MatrixComponent c => c -> Vector3 c -> IO ()
GL.rotate    (GLfloat -> GLfloat
gf GLfloat
deg) (GLfloat -> GLfloat -> GLfloat -> Vector3 GLfloat
forall a. a -> a -> a -> Vector3 a
GL.Vector3 GLfloat
0 GLfloat
0 (-GLfloat
1))
                State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
p

        Translate GLfloat
tx GLfloat
ty Picture
p
         -> IO () -> IO ()
forall a. IO a -> IO a
GL.preservingMatrix
          (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do  Vector3 GLfloat -> IO ()
forall c. MatrixComponent c => Vector3 c -> IO ()
GL.translate (GLfloat -> GLfloat -> GLfloat -> Vector3 GLfloat
forall a. a -> a -> a -> Vector3 a
GL.Vector3 (GLfloat -> GLfloat
gf GLfloat
tx) (GLfloat -> GLfloat
gf GLfloat
ty) GLfloat
0)
                State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
p

        -- Rotation -----------------------------
        -- Easy rotations are done directly to avoid calling GL.perserveMatrix.
        Rotate GLfloat
_   (Circle GLfloat
radius)
         -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle   GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
0

        Rotate GLfloat
_   (ThickCircle GLfloat
radius GLfloat
thickness)
         -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
renderCircle   GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius GLfloat
thickness

        Rotate GLfloat
deg (Arc GLfloat
a1 GLfloat
a2 GLfloat
radius)
         -> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc      GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius (GLfloat
a1GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
-GLfloat
deg) (GLfloat
a2GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
-GLfloat
deg) GLfloat
0

        Rotate GLfloat
deg (ThickArc GLfloat
a1 GLfloat
a2 GLfloat
radius GLfloat
thickness)
         -> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> GLfloat
-> IO ()
renderArc      GLfloat
0 GLfloat
0 GLfloat
circScale GLfloat
radius (GLfloat
a1GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
-GLfloat
deg) (GLfloat
a2GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
-GLfloat
deg) GLfloat
thickness


        Rotate GLfloat
deg Picture
p
         -> IO () -> IO ()
forall a. IO a -> IO a
GL.preservingMatrix
          (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do  GLfloat -> Vector3 GLfloat -> IO ()
forall c. MatrixComponent c => c -> Vector3 c -> IO ()
GL.rotate (GLfloat -> GLfloat
gf GLfloat
deg) (GLfloat -> GLfloat -> GLfloat -> Vector3 GLfloat
forall a. a -> a -> a -> Vector3 a
GL.Vector3 GLfloat
0 GLfloat
0 (-GLfloat
1))
                State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
p

        -- Scale --------------------------------
        Scale GLfloat
sx GLfloat
sy Picture
p
         -> IO () -> IO ()
forall a. IO a -> IO a
GL.preservingMatrix
          (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do  GLfloat -> GLfloat -> GLfloat -> IO ()
forall c. MatrixComponent c => c -> c -> c -> IO ()
GL.scale (GLfloat -> GLfloat
gf GLfloat
sx) (GLfloat -> GLfloat
gf GLfloat
sy) GLfloat
1
                let mscale :: GLfloat
mscale      = GLfloat -> GLfloat -> GLfloat
forall a. Ord a => a -> a -> a
max GLfloat
sx GLfloat
sy
                State -> GLfloat -> Picture -> IO ()
drawPicture State
state (GLfloat
circScale GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
* GLfloat
mscale) Picture
p

        Bitmap BitmapData
imgData ->
          let (Int
width, Int
height) = BitmapData -> (Int, Int)
bitmapSize BitmapData
imgData
          in
            State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale (Picture -> IO ()) -> Picture -> IO ()
forall a b. (a -> b) -> a -> b
$
              Rectangle -> BitmapData -> Picture
BitmapSection (Int -> Int -> Rectangle
rectAtOrigin Int
width Int
height) BitmapData
imgData

        BitmapSection
          Rectangle
            { rectPos :: Rectangle -> (Int, Int)
rectPos = (Int, Int)
imgSectionPos
            , rectSize :: Rectangle -> (Int, Int)
rectSize = (Int, Int)
imgSectionSize }
          imgData :: BitmapData
imgData@BitmapData
          { bitmapSize :: BitmapData -> (Int, Int)
bitmapSize = (Int
width, Int
height)
          , bitmapCacheMe :: BitmapData -> Bool
bitmapCacheMe = Bool
cacheMe }
          ->
           do
            let rowInfo :: Path
rowInfo =
                  -- calculate texture coordinates
                  -- remark:
                  --   On some hardware, using exact "integer" coordinates causes texture coords
                  --   with a component == 0  flip to -1. This appears as the texture flickering
                  --   on the left and sometimes show one additional row of pixels outside the
                  --   given rectangle
                  --   To prevent this we add an "epsilon-border".
                  --   This has been testet to fix the problem.
                  let defTexCoords :: Path
defTexCoords =
                        ((GLfloat, GLfloat) -> (GLfloat, GLfloat)) -> Path -> Path
forall a b. (a -> b) -> [a] -> [b]
map (\(GLfloat
x,GLfloat
y) -> (GLfloat
x GLfloat -> GLfloat -> GLfloat
forall a. Fractional a => a -> a -> a
/ Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width, GLfloat
y GLfloat -> GLfloat -> GLfloat
forall a. Fractional a => a -> a -> a
/ Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)) (Path -> Path) -> Path -> Path
forall a b. (a -> b) -> a -> b
$
                        [ (GLfloat -> GLfloat)
-> (GLfloat -> GLfloat) -> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
+GLfloat
eps) (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
+GLfloat
eps) ((GLfloat, GLfloat) -> (GLfloat, GLfloat))
-> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (GLfloat, GLfloat)
toFloatVec (Int, Int)
imgSectionPos
                        , (GLfloat -> GLfloat)
-> (GLfloat -> GLfloat) -> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
subtract GLfloat
eps) (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
+GLfloat
eps) ((GLfloat, GLfloat) -> (GLfloat, GLfloat))
-> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (GLfloat, GLfloat)
toFloatVec ((Int, Int) -> (GLfloat, GLfloat))
-> (Int, Int) -> (GLfloat, GLfloat)
forall a b. (a -> b) -> a -> b
$
                            ( (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionSize
                            , (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionPos )
                        , (GLfloat -> GLfloat)
-> (GLfloat -> GLfloat) -> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
subtract GLfloat
eps) (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
subtract GLfloat
eps) ((GLfloat, GLfloat) -> (GLfloat, GLfloat))
-> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (GLfloat, GLfloat)
toFloatVec ((Int, Int) -> (GLfloat, GLfloat))
-> (Int, Int) -> (GLfloat, GLfloat)
forall a b. (a -> b) -> a -> b
$
                            ( (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionSize
                            , (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionSize )
                        , (GLfloat -> GLfloat)
-> (GLfloat -> GLfloat) -> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
+GLfloat
eps) (GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
subtract GLfloat
eps) ((GLfloat, GLfloat) -> (GLfloat, GLfloat))
-> (GLfloat, GLfloat) -> (GLfloat, GLfloat)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (GLfloat, GLfloat)
toFloatVec ((Int, Int) -> (GLfloat, GLfloat))
-> (Int, Int) -> (GLfloat, GLfloat)
forall a b. (a -> b) -> a -> b
$
                            ( (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionPos
                            , (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionSize )
                        ]
                        :: [(Float,Float)]
                      toFloatVec :: (Int, Int) -> (GLfloat, GLfloat)
toFloatVec = (Int -> GLfloat)
-> (Int -> GLfloat) -> (Int, Int) -> (GLfloat, GLfloat)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                      vecMap :: (a -> c) -> (b -> d) -> (a,b) -> (c,d)
                      vecMap :: forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap a -> c
f b -> d
g (a
x,b
y) = (a -> c
f a
x, b -> d
g b
y)
                      eps :: GLfloat
eps = GLfloat
0.001 :: Float
                  in
                    case BitmapFormat -> RowOrder
rowOrder (BitmapData -> BitmapFormat
bitmapFormat BitmapData
imgData) of
                      RowOrder
BottomToTop -> Path
defTexCoords
                      RowOrder
TopToBottom -> Path -> Path
forall a. [a] -> [a]
reverse Path
defTexCoords

            -- Load the image data into a texture,
            -- or grab it from the cache if we've already done that before.
            tex     <- IORef [Texture] -> BitmapData -> Bool -> IO Texture
loadTexture (State -> IORef [Texture]
stateTextures State
state) BitmapData
imgData Bool
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 $
              forM_ (bitmapPath (fromIntegral $ fst imgSectionSize)
                                (fromIntegral $ snd imgSectionSize) `zip` rowInfo) $
              \((GLfloat
polygonCoordX, GLfloat
polygonCoordY), (GLfloat
textureCoordX,GLfloat
textureCoordY)) ->
              do
                TexCoord2 GLfloat -> IO ()
forall a. TexCoord a => a -> IO ()
GL.texCoord (TexCoord2 GLfloat -> IO ()) -> TexCoord2 GLfloat -> IO ()
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> TexCoord2 GLfloat
forall a. a -> a -> TexCoord2 a
GL.TexCoord2 (GLfloat -> GLfloat
gf GLfloat
textureCoordX) (GLfloat -> GLfloat
gf GLfloat
textureCoordY)
                Vertex2 GLfloat -> IO ()
forall a. Vertex a => a -> IO ()
GL.vertex   (Vertex2 GLfloat -> IO ()) -> Vertex2 GLfloat -> IO ()
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> Vertex2 GLfloat
forall a. a -> a -> Vertex2 a
GL.Vertex2   (GLfloat -> GLfloat
gf GLfloat
polygonCoordX) (GLfloat -> GLfloat
gf GLfloat
polygonCoordY)

            -- Restore color
            GL.currentColor $= oldColor

            -- Disable texturing
            GL.texture GL.Texture2D $= GL.Disabled

            -- Free uncachable texture objects.
            freeTexture tex

        Pictures [Picture]
ps
         -> (Picture -> IO ()) -> [Picture] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale) [Picture]
ps

-- Errors ---------------------------------------------------------------------
checkErrors :: String -> IO ()
checkErrors :: String -> IO ()
checkErrors String
place
 = do   errors          <- GettableStateVar [Error] -> GettableStateVar [Error]
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *).
MonadIO m =>
GettableStateVar [Error] -> m [Error]
get (GettableStateVar [Error] -> GettableStateVar [Error])
-> GettableStateVar [Error] -> GettableStateVar [Error]
forall a b. (a -> b) -> a -> b
$ GettableStateVar [Error]
GLU.errors
        when (not $ null errors)
         $ mapM_ (handleError place) errors

handleError :: String -> GLU.Error -> IO ()
handleError :: String -> Error -> IO ()
handleError String
place Error
err
 = case Error
err of
    GLU.Error ErrorCategory
GLU.StackOverflow String
_
     -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ String
"Gloss / OpenGL Stack Overflow " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
place
      , String
"  This program uses the Gloss vector graphics library, which tried to"
      , String
"  draw a picture using more nested transforms (Translate/Rotate/Scale)"
      , String
"  than your OpenGL implementation supports. The OpenGL spec requires"
      , String
"  all implementations to have a transform stack depth of at least 32,"
      , String
"  and Gloss tries not to push the stack when it doesn't have to, but"
      , String
"  that still wasn't enough."
      , String
""
      , String
"  You should complain to your harware vendor that they don't provide"
      , String
"  a better way to handle this situation at the OpenGL API level."
      , String
""
      , String
"  To make this program work you'll need to reduce the number of nested"
      , String
"  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 ErrorCategory
GLU.InvalidOperation String
_
     -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Error
_
     -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
     [  String
"Gloss / OpenGL Internal Error " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
place
     ,  String
"  Please report this on haskell-gloss@googlegroups.com."
     ,  Error -> String
forall a. Show a => a -> String
show Error
err ]


-- Textures -------------------------------------------------------------------
-- | Load a texture into the OpenGL context, or retrieve the existing handle
--   from our own cache.
loadTexture
        :: IORef [Texture] -- ^ Existing texture cache.
        -> BitmapData      -- ^ Texture data.
        -> Bool            -- ^ Force cache for newly loaded textures.
        -> IO Texture

loadTexture :: IORef [Texture] -> BitmapData -> Bool -> IO Texture
loadTexture IORef [Texture]
refTextures imgData :: BitmapData
imgData@BitmapData{ bitmapSize :: BitmapData -> (Int, Int)
bitmapSize=(Int
width,Int
height) } Bool
cacheMe
 = do   textures        <- IORef [Texture] -> IO [Texture]
forall a. IORef a -> IO a
readIORef IORef [Texture]
refTextures

        -- Try and find this same texture in the cache.
        name            <- makeStableName imgData
        let mTexCached
                = (Texture -> Bool) -> [Texture] -> Maybe Texture
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Texture
tex -> Texture -> StableName BitmapData
texName   Texture
tex StableName BitmapData -> StableName BitmapData -> Bool
forall a. Eq a => a -> a -> Bool
== StableName BitmapData
name
                             Bool -> Bool -> Bool
&& Texture -> Int
texWidth  Texture
tex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
width
                             Bool -> Bool -> Bool
&& Texture -> Int
texHeight Texture
tex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
height)
                [Texture]
textures

        case mTexCached of
         Just Texture
tex
          ->    Texture -> IO Texture
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
tex

         Maybe Texture
Nothing
          -> do tex <- BitmapData -> IO Texture
installTexture BitmapData
imgData
                when cacheMe
                 $ writeIORef refTextures (tex : textures)
                return tex


-- | Install a texture into the OpenGL context,
--   returning the new texture handle.
installTexture :: BitmapData -> IO Texture
installTexture :: BitmapData -> IO Texture
installTexture bitmapData :: BitmapData
bitmapData@(BitmapData Int
_ BitmapFormat
fmt (Int
width,Int
height) Bool
cacheMe ForeignPtr Word8
fptr)
 = do
        let glFormat :: PixelFormat
glFormat
                = case BitmapFormat -> PixelFormat
pixelFormat BitmapFormat
fmt of
                        PixelFormat
PxABGR -> PixelFormat
GL.ABGR
                        PixelFormat
PxRGBA -> PixelFormat
GL.RGBA

        -- Allocate texture handle for texture
        [tex] <- Int -> IO [TextureObject]
forall a (m :: * -> *).
(GeneratableObjectName a, MonadIO m) =>
Int -> m [a]
forall (m :: * -> *). MonadIO m => Int -> m [TextureObject]
GL.genObjectNames Int
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 Word8
ptr ->
           TextureTarget2D
-> Proxy
-> Level
-> PixelInternalFormat
-> TextureSize2D
-> Level
-> PixelData Word8
-> IO ()
forall t a.
TwoDimensionalTextureTarget t =>
t
-> Proxy
-> Level
-> PixelInternalFormat
-> TextureSize2D
-> Level
-> PixelData a
-> IO ()
GL.texImage2D
                TextureTarget2D
GL.Texture2D
                Proxy
GL.NoProxy
                Level
0
                PixelInternalFormat
GL.RGBA8
                (Level -> Level -> TextureSize2D
GL.TextureSize2D
                        (Int -> Level
gsizei Int
width)
                        (Int -> Level
gsizei Int
height))
                Level
0
                (PixelFormat -> DataType -> Ptr Word8 -> PixelData Word8
forall a. PixelFormat -> DataType -> Ptr a -> PixelData a
GL.PixelData PixelFormat
glFormat DataType
GL.UnsignedByte Ptr Word8
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 :: Texture -> IO ()
freeTexture Texture
tex
 | Texture -> Bool
texCacheMe Texture
tex       = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 | Bool
otherwise            = [TextureObject] -> IO ()
forall a (m :: * -> *). (ObjectName a, MonadIO m) => [a] -> m ()
forall (m :: * -> *). MonadIO m => [TextureObject] -> m ()
GL.deleteObjectNames [Texture -> TextureObject
texObject Texture
tex]


-- Utils ----------------------------------------------------------------------
-- | Turn alpha blending on or off
setBlendAlpha :: Bool -> IO ()
setBlendAlpha :: Bool -> IO ()
setBlendAlpha Bool
state
        | Bool
state
        = do    StateVar Capability
GL.blend        StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Enabled
                StateVar (BlendingFactor, BlendingFactor)
GL.blendFunc    StateVar (BlendingFactor, BlendingFactor)
-> (BlendingFactor, BlendingFactor) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (BlendingFactor, BlendingFactor)
-> (BlendingFactor, BlendingFactor) -> m ()
$= (BlendingFactor
GL.SrcAlpha, BlendingFactor
GL.OneMinusSrcAlpha)

        | Bool
otherwise
        = do    StateVar Capability
GL.blend        StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Disabled
                StateVar (BlendingFactor, BlendingFactor)
GL.blendFunc    StateVar (BlendingFactor, BlendingFactor)
-> (BlendingFactor, BlendingFactor) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (BlendingFactor, BlendingFactor)
-> (BlendingFactor, BlendingFactor) -> m ()
$= (BlendingFactor
GL.One, BlendingFactor
GL.Zero)


-- | Turn line smoothing on or off
setLineSmooth :: Bool -> IO ()
setLineSmooth :: Bool -> IO ()
setLineSmooth Bool
state
        | Bool
state         = StateVar Capability
GL.lineSmooth StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Enabled
        | Bool
otherwise     = StateVar Capability
GL.lineSmooth StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Capability -> Capability -> m ()
$= Capability
GL.Disabled


vertexPFs ::    [(Float, Float)] -> IO ()
vertexPFs :: Path -> IO ()
vertexPFs []    = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
vertexPFs ((GLfloat
x, GLfloat
y) : Path
rest)
 = do   Vertex2 GLfloat -> IO ()
forall a. Vertex a => a -> IO ()
GL.vertex (Vertex2 GLfloat -> IO ()) -> Vertex2 GLfloat -> IO ()
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> Vertex2 GLfloat
forall a. a -> a -> Vertex2 a
GL.Vertex2 (GLfloat -> GLfloat
gf GLfloat
x) (GLfloat -> GLfloat
gf GLfloat
y)
        Path -> IO ()
vertexPFs Path
rest
{-# INLINE vertexPFs #-}