{-# 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 -> Float -> Picture -> IO ()
renderPicture state :: State
state circScale :: Float
circScale picture :: 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 "before drawPicture."
        State -> Float -> Picture -> IO ()
drawPicture State
state Float
circScale Picture
picture
        String -> IO ()
checkErrors "after drawPicture."


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

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

        -- line
        Line path :: 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
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 radius :: Float
radius
         ->  Float -> Float -> Float -> Float -> Float -> IO ()
renderCircle 0 0 Float
circScale Float
radius 0

        ThickCircle radius :: Float
radius thickness :: Float
thickness
         ->  Float -> Float -> Float -> Float -> Float -> IO ()
renderCircle 0 0 Float
circScale Float
radius Float
thickness

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

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

        -- stroke text
        --      text looks weird when we've got blend on,
        --      so disable it during the renderString call.
        Text str :: 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 col :: Color
col p :: Picture
p
         |  State -> Bool
stateColor State
state
         ->  do Color4 Float
oldColor         <- StateVar (Color4 Float) -> IO (Color4 Float)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar (Color4 Float)
GL.currentColor

                let RGBA r :: Float
r g :: Float
g b :: Float
b a :: Float
a  = Color
col

                StateVar (Color4 Float)
GL.currentColor  StateVar (Color4 Float) -> Color4 Float -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Float -> Float -> Float -> Float -> Color4 Float
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 (Float -> Float
gf Float
r) (Float -> Float
gf Float
g) (Float -> Float
gf Float
b) (Float -> Float
gf Float
a)
                State -> Float -> Picture -> IO ()
drawPicture State
state Float
circScale Picture
p
                StateVar (Color4 Float)
GL.currentColor  StateVar (Color4 Float) -> Color4 Float -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Color4 Float
oldColor

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


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

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

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

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

        Translate tx :: Float
tx ty :: Float
ty (Rotate deg :: Float
deg p :: 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 Float -> IO ()
forall c. MatrixComponent c => Vector3 c -> IO ()
GL.translate (Float -> Float -> Float -> Vector3 Float
forall a. a -> a -> a -> Vector3 a
GL.Vector3 (Float -> Float
gf Float
tx) (Float -> Float
gf Float
ty) 0)
                Float -> Vector3 Float -> IO ()
forall c. MatrixComponent c => c -> Vector3 c -> IO ()
GL.rotate    (Float -> Float
gf Float
deg) (Float -> Float -> Float -> Vector3 Float
forall a. a -> a -> a -> Vector3 a
GL.Vector3 0 0 (-1))
                State -> Float -> Picture -> IO ()
drawPicture State
state Float
circScale Picture
p

        Translate tx :: Float
tx ty :: Float
ty p :: 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 Float -> IO ()
forall c. MatrixComponent c => Vector3 c -> IO ()
GL.translate (Float -> Float -> Float -> Vector3 Float
forall a. a -> a -> a -> Vector3 a
GL.Vector3 (Float -> Float
gf Float
tx) (Float -> Float
gf Float
ty) 0)
                State -> Float -> Picture -> IO ()
drawPicture State
state Float
circScale Picture
p

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

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

        Rotate deg :: Float
deg (Arc a1 :: Float
a1 a2 :: Float
a2 radius :: Float
radius)
         -> Float
-> Float -> Float -> Float -> Float -> Float -> Float -> IO ()
renderArc      0 0 Float
circScale Float
radius (Float
a1Float -> Float -> Float
forall a. Num a => a -> a -> a
-Float
deg) (Float
a2Float -> Float -> Float
forall a. Num a => a -> a -> a
-Float
deg) 0

        Rotate deg :: Float
deg (ThickArc a1 :: Float
a1 a2 :: Float
a2 radius :: Float
radius thickness :: Float
thickness)
         -> Float
-> Float -> Float -> Float -> Float -> Float -> Float -> IO ()
renderArc      0 0 Float
circScale Float
radius (Float
a1Float -> Float -> Float
forall a. Num a => a -> a -> a
-Float
deg) (Float
a2Float -> Float -> Float
forall a. Num a => a -> a -> a
-Float
deg) Float
thickness


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

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

        Bitmap imgData :: BitmapData
imgData ->
          let (width :: Int
width, height :: Int
height) = BitmapData -> (Int, Int)
bitmapSize BitmapData
imgData
          in
            State -> Float -> Picture -> IO ()
drawPicture State
state Float
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 = (width :: Int
width, height :: 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 =
                        ((Float, Float) -> (Float, Float)) -> Path -> Path
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: Float
x,y :: Float
y) -> (Float
x Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width, Float
y Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)) (Path -> Path) -> Path -> Path
forall a b. (a -> b) -> a -> b
$
                        [ (Float -> Float)
-> (Float -> Float) -> (Float, Float) -> (Float, Float)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
eps) (Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
eps) ((Float, Float) -> (Float, Float))
-> (Float, Float) -> (Float, Float)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Float, Float)
toFloatVec (Int, Int)
imgSectionPos
                        , (Float -> Float)
-> (Float -> Float) -> (Float, Float) -> (Float, Float)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (Float -> Float -> Float
forall a. Num a => a -> a -> a
subtract Float
eps) (Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
eps) ((Float, Float) -> (Float, Float))
-> (Float, Float) -> (Float, Float)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Float, Float)
toFloatVec ((Int, Int) -> (Float, Float)) -> (Int, Int) -> (Float, Float)
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 )
                        , (Float -> Float)
-> (Float -> Float) -> (Float, Float) -> (Float, Float)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (Float -> Float -> Float
forall a. Num a => a -> a -> a
subtract Float
eps) (Float -> Float -> Float
forall a. Num a => a -> a -> a
subtract Float
eps) ((Float, Float) -> (Float, Float))
-> (Float, Float) -> (Float, Float)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Float, Float)
toFloatVec ((Int, Int) -> (Float, Float)) -> (Int, Int) -> (Float, Float)
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 )
                        , (Float -> Float)
-> (Float -> Float) -> (Float, Float) -> (Float, Float)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap (Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
eps) (Float -> Float -> Float
forall a. Num a => a -> a -> a
subtract Float
eps) ((Float, Float) -> (Float, Float))
-> (Float, Float) -> (Float, Float)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Float, Float)
toFloatVec ((Int, Int) -> (Float, Float)) -> (Int, Int) -> (Float, Float)
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) -> (Float, Float)
toFloatVec = (Int -> Float) -> (Int -> Float) -> (Int, Int) -> (Float, Float)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                      vecMap :: (a -> c) -> (b -> d) -> (a,b) -> (c,d)
                      vecMap :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)
vecMap f :: a -> c
f g :: b -> d
g (x :: a
x,y :: b
y) = (a -> c
f a
x, b -> d
g b
y)
                      eps :: Float
eps = 0.001 :: Float
                  in
                    case BitmapFormat -> RowOrder
rowOrder (BitmapData -> BitmapFormat
bitmapFormat BitmapData
imgData) of
                      BottomToTop -> Path
defTexCoords
                      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 Float
oldColor <- StateVar (Color4 Float) -> IO (Color4 Float)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar (Color4 Float)
GL.currentColor
            StateVar (Color4 Float)
GL.currentColor StateVar (Color4 Float) -> Color4 Float -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Float -> Float -> Float -> Float -> Color4 Float
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 1.0 1.0 1.0 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
$
              [((Float, Float), (Float, Float))]
-> (((Float, Float), (Float, Float)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Float -> Float -> Path
bitmapPath (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
imgSectionSize)
                                (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
imgSectionSize) Path -> Path -> [((Float, Float), (Float, Float))]
forall a b. [a] -> [b] -> [(a, b)]
`zip` Path
rowInfo) ((((Float, Float), (Float, Float)) -> IO ()) -> IO ())
-> (((Float, Float), (Float, Float)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
              \((polygonCoordX :: Float
polygonCoordX, polygonCoordY :: Float
polygonCoordY), (textureCoordX :: Float
textureCoordX,textureCoordY :: Float
textureCoordY)) ->
              do
                TexCoord2 Float -> IO ()
forall a. TexCoord a => a -> IO ()
GL.texCoord (TexCoord2 Float -> IO ()) -> TexCoord2 Float -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> Float -> TexCoord2 Float
forall a. a -> a -> TexCoord2 a
GL.TexCoord2 (Float -> Float
gf Float
textureCoordX) (Float -> Float
gf Float
textureCoordY)
                Vertex2 Float -> IO ()
forall a. Vertex a => a -> IO ()
GL.vertex   (Vertex2 Float -> IO ()) -> Vertex2 Float -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Vertex2 Float
forall a. a -> a -> Vertex2 a
GL.Vertex2   (Float -> Float
gf Float
polygonCoordX) (Float -> Float
gf Float
polygonCoordY)

            -- Restore color
            StateVar (Color4 Float)
GL.currentColor StateVar (Color4 Float) -> Color4 Float -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Color4 Float
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 ps :: [Picture]
ps
         -> (Picture -> IO ()) -> [Picture] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (State -> Float -> Picture -> IO ()
drawPicture State
state Float
circScale) [Picture]
ps

-- Errors ---------------------------------------------------------------------
checkErrors :: String -> IO ()
checkErrors :: String -> IO ()
checkErrors place :: 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 place :: String
place err :: Error
err
 = case Error
err of
    GLU.Error GLU.StackOverflow _
     -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ "Gloss / OpenGL Stack Overflow " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
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 _
     -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    _
     -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
     [  "Gloss / OpenGL Internal Error " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
place
     ,  "  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 refTextures :: IORef [Texture]
refTextures imgData :: BitmapData
imgData@BitmapData{ bitmapSize :: BitmapData -> (Int, Int)
bitmapSize=(width :: Int
width,height :: Int
height) } cacheMe :: 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 (\tex :: 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 tex :: Texture
tex
          ->    Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
tex

         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 _ fmt :: BitmapFormat
fmt (width :: Int
width,height :: Int
height) cacheMe :: Bool
cacheMe fptr :: ForeignPtr Word8
fptr)
 = do
        let glFormat :: PixelFormat
glFormat
                = case BitmapFormat -> PixelFormat
pixelFormat BitmapFormat
fmt of
                        PxABGR -> PixelFormat
GL.ABGR
                        PxRGBA -> PixelFormat
GL.RGBA

        -- Allocate texture handle for texture
        [tex :: TextureObject
tex] <- Int -> IO [TextureObject]
forall a (m :: * -> *).
(GeneratableObjectName a, MonadIO m) =>
Int -> m [a]
GL.genObjectNames 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 :: 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
                0
                PixelInternalFormat
GL.RGBA8
                (Level -> Level -> TextureSize2D
GL.TextureSize2D
                        (Int -> Level
gsizei Int
width)
                        (Int -> Level
gsizei Int
height))
                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 tex :: 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 state :: 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 state :: 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 ((x :: Float
x, y :: Float
y) : rest :: Path
rest)
 = do   Vertex2 Float -> IO ()
forall a. Vertex a => a -> IO ()
GL.vertex (Vertex2 Float -> IO ()) -> Vertex2 Float -> IO ()
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Vertex2 Float
forall a. a -> a -> Vertex2 a
GL.Vertex2 (Float -> Float
gf Float
x) (Float -> Float
gf Float
y)
        Path -> IO ()
vertexPFs Path
rest
{-# INLINE vertexPFs #-}