{-# 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
renderPicture
:: State
-> Float
-> Picture
-> IO ()
renderPicture :: State -> Float -> Picture -> IO ()
renderPicture state :: State
state circScale :: Float
circScale picture :: Picture
picture
= do
Bool -> IO ()
setLineSmooth (State -> Bool
stateLineSmooth State
state)
Bool -> IO ()
setBlendAlpha (State -> Bool
stateBlendAlpha State
state)
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
Blank
-> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 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 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 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
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
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
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
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 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 =
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
Texture
tex <- IORef [Texture] -> BitmapData -> Bool -> IO Texture
loadTexture (State -> IORef [Texture]
stateTextures State
state) BitmapData
imgData Bool
cacheMe
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)
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
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)
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
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)
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
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
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
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." ]
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 ]
loadTexture
:: IORef [Texture]
-> BitmapData
-> Bool
-> 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
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
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
[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
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)
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 }
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]
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)
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 #-}