{-# 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 -> 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 (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
         -> PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.Polygon
                (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Path -> IO ()
vertexPFs 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 ()
$= 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 ()
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 ()
$= Capability
GL.Enabled

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

                let RGBA GLfloat
r GLfloat
g GLfloat
b GLfloat
a  = Color
col

                StateVar (Color4 GLfloat)
GL.currentColor  StateVar (Color4 GLfloat) -> Color4 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 (GLfloat -> GLfloat
gf GLfloat
r) (GLfloat -> GLfloat
gf GLfloat
g) (GLfloat -> GLfloat
gf GLfloat
b) (GLfloat -> GLfloat
gf GLfloat
a)
                State -> GLfloat -> Picture -> IO ()
drawPicture State
state GLfloat
circScale Picture
p
                StateVar (Color4 GLfloat)
GL.currentColor  StateVar (Color4 GLfloat) -> Color4 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Color4 GLfloat
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.
            Texture
tex     <- IORef [Texture] -> BitmapData -> Bool -> IO Texture
loadTexture (State -> IORef [Texture]
stateTextures State
state) BitmapData
imgData Bool
cacheMe

            -- Set up wrap and filtering mode
            TextureTarget2D
-> TextureCoordName -> StateVar (Repetition, Clamping)
forall t.
ParameterizedTextureTarget t =>
t -> TextureCoordName -> StateVar (Repetition, Clamping)
GL.textureWrapMode TextureTarget2D
GL.Texture2D TextureCoordName
GL.S StateVar (Repetition, Clamping) -> (Repetition, Clamping) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Repetition
GL.Repeated, Clamping
GL.Repeat)
            TextureTarget2D
-> TextureCoordName -> StateVar (Repetition, Clamping)
forall t.
ParameterizedTextureTarget t =>
t -> TextureCoordName -> StateVar (Repetition, Clamping)
GL.textureWrapMode TextureTarget2D
GL.Texture2D TextureCoordName
GL.T StateVar (Repetition, Clamping) -> (Repetition, Clamping) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Repetition
GL.Repeated, Clamping
GL.Repeat)
            TextureTarget2D
-> StateVar (MinificationFilter, MagnificationFilter)
forall t.
ParameterizedTextureTarget t =>
t -> StateVar (MinificationFilter, MagnificationFilter)
GL.textureFilter   TextureTarget2D
GL.Texture2D      StateVar (MinificationFilter, MagnificationFilter)
-> (MinificationFilter, MagnificationFilter) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= ((MagnificationFilter
GL.Nearest, Maybe MagnificationFilter
forall a. Maybe a
Nothing), MagnificationFilter
GL.Nearest)

            -- Enable texturing
            TextureTarget2D -> StateVar Capability
forall t. ParameterizedTextureTarget t => t -> StateVar Capability
GL.texture TextureTarget2D
GL.Texture2D StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
GL.Enabled
            StateVar TextureFunction
GL.textureFunction      StateVar TextureFunction -> TextureFunction -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= TextureFunction
GL.Combine

            -- Set current texture
            TextureTarget2D -> StateVar (Maybe TextureObject)
forall t.
BindableTextureTarget t =>
t -> StateVar (Maybe TextureObject)
GL.textureBinding TextureTarget2D
GL.Texture2D StateVar (Maybe TextureObject) -> Maybe TextureObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= TextureObject -> Maybe TextureObject
forall a. a -> Maybe a
Just (Texture -> TextureObject
texObject Texture
tex)

            -- Set to opaque
            Color4 GLfloat
oldColor <- StateVar (Color4 GLfloat) -> IO (Color4 GLfloat)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar (Color4 GLfloat)
GL.currentColor
            StateVar (Color4 GLfloat)
GL.currentColor StateVar (Color4 GLfloat) -> Color4 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 GLfloat
1.0 GLfloat
1.0 GLfloat
1.0 GLfloat
1.0

            -- Draw textured polygon
            PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.Polygon (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              [((GLfloat, GLfloat), (GLfloat, GLfloat))]
-> (((GLfloat, GLfloat), (GLfloat, GLfloat)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (GLfloat -> GLfloat -> Path
bitmapPath (Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLfloat) -> Int -> GLfloat
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionSize)
                                (Int -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLfloat) -> Int -> GLfloat
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionSize) Path -> Path -> [((GLfloat, GLfloat), (GLfloat, GLfloat))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` Path
rowInfo) ((((GLfloat, GLfloat), (GLfloat, GLfloat)) -> IO ()) -> IO ())
-> (((GLfloat, GLfloat), (GLfloat, GLfloat)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
              \((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
            StateVar (Color4 GLfloat)
GL.currentColor StateVar (Color4 GLfloat) -> Color4 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Color4 GLfloat
oldColor

            -- Disable texturing
            TextureTarget2D -> StateVar Capability
forall t. ParameterizedTextureTarget t => t -> StateVar Capability
GL.texture TextureTarget2D
GL.Texture2D StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
GL.Disabled

            -- Free uncachable texture objects.
            Texture -> IO ()
freeTexture Texture
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   [Error]
errors          <- GettableStateVar [Error] -> GettableStateVar [Error]
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (GettableStateVar [Error] -> GettableStateVar [Error])
-> GettableStateVar [Error] -> GettableStateVar [Error]
forall a b. (a -> b) -> a -> b
$ GettableStateVar [Error]
GLU.errors
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Error] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Error]
errors)
         (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Error -> IO ()) -> [Error] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Error -> IO ()
handleError String
place) [Error]
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 (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   [Texture]
textures        <- IORef [Texture] -> IO [Texture]
forall a. IORef a -> IO a
readIORef IORef [Texture]
refTextures

        -- Try and find this same texture in the cache.
        StableName BitmapData
name            <- BitmapData -> IO (StableName BitmapData)
forall a. a -> IO (StableName a)
makeStableName BitmapData
imgData
        let mTexCached :: Maybe Texture
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 Maybe Texture
mTexCached of
         Just Texture
tex
          ->    Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
tex

         Maybe Texture
Nothing
          -> do Texture
tex <- BitmapData -> IO Texture
installTexture BitmapData
imgData
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cacheMe
                 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef [Texture] -> [Texture] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Texture]
refTextures (Texture
tex Texture -> [Texture] -> [Texture]
forall a. a -> [a] -> [a]
: [Texture]
textures)
                Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
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
        [TextureObject
tex] <- Int -> IO [TextureObject]
forall a (m :: * -> *).
(GeneratableObjectName a, MonadIO m) =>
Int -> m [a]
GL.genObjectNames Int
1
        TextureTarget2D -> StateVar (Maybe TextureObject)
forall t.
BindableTextureTarget t =>
t -> StateVar (Maybe TextureObject)
GL.textureBinding TextureTarget2D
GL.Texture2D StateVar (Maybe TextureObject) -> Maybe TextureObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= TextureObject -> Maybe TextureObject
forall a. a -> Maybe a
Just TextureObject
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.
        ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr
         ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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.
        StableName BitmapData
name    <- BitmapData -> IO (StableName BitmapData)
forall a. a -> IO (StableName a)
makeStableName BitmapData
bitmapData

        Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return  Texture :: StableName BitmapData
-> Int
-> Int
-> ForeignPtr Word8
-> TextureObject
-> Bool
-> Texture
Texture
                { texName :: StableName BitmapData
texName       = StableName BitmapData
name
                , texWidth :: Int
texWidth      = Int
width
                , texHeight :: Int
texHeight     = Int
height
                , texData :: ForeignPtr Word8
texData       = ForeignPtr Word8
fptr
                , texObject :: TextureObject
texObject     = TextureObject
tex
                , texCacheMe :: Bool
texCacheMe    = Bool
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 (m :: * -> *) a. Monad m => a -> m a
return ()
 | Bool
otherwise            = [TextureObject] -> IO ()
forall a (m :: * -> *). (ObjectName a, MonadIO m) => [a] -> 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 ()
$= 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 ()
$= (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 ()
$= 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 ()
$= (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 ()
$= 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 ()
$= Capability
GL.Disabled


vertexPFs ::    [(Float, Float)] -> IO ()
vertexPFs :: Path -> IO ()
vertexPFs []    = () -> IO ()
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 #-}