    {-# 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 #-}