I am currently trying to write a graphical application in haskell using OpenGL and GLFW-b. I am rather new to OpenGL, and I am having some problems displaying the TextureObjects. I have tried two ways of doing it.
The first way I tried was to store the textures as an TextureObject, and then simply using it as an input argument to the render function (see below). However, this doesn't work, as
the texture objects simply appear as white squares.
I will also note that it probably took several second for the program to start, presumably because it loaded all the graphics.
The second thing I tried was to store the textures as an IO TextureObject. This worked
, but it is very slow. It slows down to a few frames per second. I suspect this is because the textures need to be reloaded every time they are drawn. In order to test this, I renamed the textures while the program are running, and indeed the program crashed, confirming that it needs to reload the textures every iteration.
The texture is loaded with the function
loadTexture' :: FilePath -> IO TextureObject
loadTexture' f = do
tex <- either error id <$> readTexture f
textureFilter Texture2D $= ((Linear', Nothing), Linear')
return tex
and rendered with
renderTexture :: Area -> Area -> TextureObject -> IO()
renderTexture window area tex =
let (x,x') = xRangeToGL window $ getXRange area
(y,y') = yRangeToGL window $ getYRange area
in do textureBinding Texture2D $= Just tex
renderPrimitive Quads $ do
col
txc 1 1 >> ver x' y'
txc 1 0 >> ver x' y
txc 0 0 >> ver x y
txc 0 1 >> ver x y'
where col = color (Color3 1.0 1.0 1.0 :: Color3 GLfloat)
ver x y = vertex (Vertex2 x y :: Vertex2 GLfloat)
txc u v = texCoord (TexCoord2 u v :: TexCoord2 GLfloat)
The OpenGL settings are
clearColor $= Color4 r g b 1.0
depthFunc $= Just Lequal
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
normalize $= Enabled
texture Texture2D $= Enabled
shadeModel $= Smooth
This is my first post, so please tell me if I have missed something, and thank you for your kind assistance!
Bad practice solution:
I have come up with a solution, I have added it as an edit, rather than a solution, because I'm not certain that it is good practice --- it is not the type of answer I would like to have to this post, but it can still be of use to those who wish to answer.
Calling loadTexture using unsafeCoerce,
unsafePerformIO $ loadTexture "foo/bar.png"
works. However, rewriting the loadTexture' function as
loadTexture' :: FilePath -> IO TextureObject
loadTexture' f = do
let tex = unsafePerformIO $ either error id <$> readTexture f
textureFilter Texture2D $= ((Linear', Nothing), Linear')
return tex
does not work.
Related
I am just started haskell gloss. I learnt a little about it functions. I am trying to draw a chess board in haskell. The main problem is that everything is being drawn in the center. If I used the function translate the board is being draw at random position. That's probably because translate moves from moves the distance given from current position not to the exact point which is given.
Is there a way in gloss haskell so that we can move to a specific point like setTransform or translateTo. Or is there any function which tells coordinates of current point at which we are at.
module Main where
import Graphics.Gloss
import Lib (someFunc)
blockSize :: Float
blockSize = 50
board :: [[Int]]
board = replicate 8 (replicate 8 0)
drawTile :: Float -> Float -> Color -> Picture
drawTile a b col = translate a b $ color col $ rectangleSolid blockSize blockSize
-- drawRow :: Int -> Pictur
-- drawRow =
toInt :: Float -> Integer
toInt = round
getColor :: Float -> Float -> Color
getColor i j = if even $ toInt ((i * 8) + j) then red else blue
screenHeight = 700
screenWidth = 1000
drawing :: Picture
drawing = pictures [drawTile (row * blockSize) (e * blockSize) (getColor row e) | row <- [0 .. 8], e <- [0 .. 8]]
-- moveToStart = viewPortTranslate
main :: IO ()
main = display (InWindow (show board) (screenWidth, screenHeight) (10, 10)) white (translate 0 0 drawing)
Edit: I don't want to fix this specific problem by using some math tricks. What I want to know is that how can I translate to a specfic position. Like when I do someFunc 0 0 the position should go to 0 0 top right corner.
If its not possible please tell the way to get the current transform point.
There is no existing Gloss function that will take an arbitrary picture and move it so its top-left corner is in the top-left corner of the screen. All existing transformation functions in Gloss are relative, so there's no way to make an "absolute" move to a specific point.
The best you can probably do is arrange to draw your picture so its origin matches its top-left corner, and then translate it up and left by half the screen height and width.
import Graphics.Gloss
-- chess board with top-left corner at (0,0), one unit in width and height
chess = scale (1/8) (1/8) $ pictures [square x y | x <- [0..7], y <- [0..8]]
where square x y =
Color (if even (x+y) then red else black) $
translate (fromIntegral x+0.5) (-fromIntegral y -0.5) $ rectangleSolid 1 1
main = display (InWindow "Layout" (1000,700) (10,10)) white $
-- scale to a 700x700 square (with origin still at top-level corner)
-- then translate origin from default position at center of window
-- to top-left corner, by moving half the window width and height
translate (-500) 350 $ scale 700 700 chess
Simplifying the reality, my OpenGL program has the following structure:
At the beginning, there's a function f : (Double,Double,Double) -> Double.
Then there is a function triangulize :: ((Double,Double,Double) -> Double) -> [Triangle] such that triangulize f calculates a triangular mesh of the surface f(x,y,z)=0.
Then there is the displayCallback, a function display :: IORef Float -> DisplayCallBack which displays the graphics (that is to say it displays the triangular mesh). The first argument IORef Float is here to rotate the graphics, and its value (the angle of the rotation) changes when the user presses a key on the keyboard, thanks to the keyboardCallback defined later. Don't forget that the display function calls triangulize f.
Then the problem is the following one. When the user presses the key to rotate the graphic, the display function is triggered. And then triangulize f is re-evaluated, whereas it doesn't need to be re-evaluated: rotating the graphics does not change the triangular mesh (i.e. the result of triangulize f is the same as before).
So, is there a way to rotate the graphics by pressing a key without triggering triangulize f ? In other words, to "freeze" triangulize f so that it is evaluated only once and is never re-evaluated, which is time-consuming but useless since anyway the result is always the same.
I believe this is a standard way to rotate a graphics in Haskell OpenGL (I viewed that way in some tutos), so I don't think it is necessary to post my code. But of course I can post it if needed.
The reality is more complicated since there are other IORef's to control some parameters of the surface. But I would like to firstly know some solutions for this simplified situation.
EDIT: more details and some code
Simplified code
So, if I follow the simplified description above, my program looks like
fBretzel5 :: (Double,Double,Double) -> Double
fBretzel5 (x,y,z) = ((x*x+y*y/4-1)*(x*x/4+y*y-1))^2 + z*z
triangles :: [Triangle] -- Triangle: triplet of 3 vertices
triangles =
triangulize fBretzel5 ((-2.5,2.5),(-2.5,2.5),(-0.5,0.5))
-- "triangulize f (xbounds, ybounds, zbounds)"
-- calculates a triangular mesh of the surface f(x,y,z)=0
display :: IORef Float -> DisplayCallback
display rot = do
clear [ColorBuffer, DepthBuffer]
rot' <- get rot
loadIdentity
rotate rot $ Vector3 1 0 0
renderPrimitive Triangles $ do
materialDiffuse FrontAndBack $= red
mapM_ drawTriangle triangles
swapBuffers
where
drawTriangle (v1,v2,v3) = do
triangleNormal (v1,v2,v3) -- the normal of the triangle
vertex v1
vertex v2
vertex v3
keyboard :: IORef Float -- rotation angle
-> KeyboardCallback
keyboard rot c _ = do
case c of
'e' -> rot $~! subtract 2
'r' -> rot $~! (+ 2)
'q' -> leaveMainLoop
_ -> return ()
postRedisplay Nothing
This causes the issue described above. Each time the key 'e' or 'r' is pressed, the triangulize function runs while its output remains the same.
True code (almost)
Now, here is a version of my program closest to the reality. In fact, it calculates a triangular mesh for a surface f(x,y,z)=l, where the "isolevel" l can be changed with the keyboard.
voxel :: IO Voxel
voxel = makeVoxel fBretzel5 ((-2.5,2.5),(-2.5,2.5),(-0.5,0.5))
-- the voxel is a 3D-array of points; each entry of the array is
-- the value of the function at this point
-- !! the voxel should never changes throughout the program !!
trianglesBretz :: Double -> IO [Triangle]
trianglesBretz level = do
vxl <- voxel
computeContour3d vxl level
-- "computeContour3d vxl level" calculates a triangular mesh
-- of the surface f(x,y,z)=level
display :: IORef Float -> IORef Float -> DisplayCallback
display rot level = do
clear [ColorBuffer, DepthBuffer]
rot' <- get rot
level' <- get level
triangles <- trianglesBretz level'
loadIdentity
rotate rot $ Vector3 1 0 0
renderPrimitive Triangles $ do
materialDiffuse FrontAndBack $= red
mapM_ drawTriangle triangles
swapBuffers
where
drawTriangle (v1,v2,v3) = do
triangleNormal (v1,v2,v3) -- the normal of the triangle
vertex v1
vertex v2
vertex v3
keyboard :: IORef Float -- rotation angle
-> IORef Double -- isolevel
-> KeyboardCallback
keyboard rot level c _ = do
case c of
'e' -> rot $~! subtract 2
'r' -> rot $~! (+ 2)
'h' -> level $~! (+ 0.1)
'n' -> level $~! subtract 0.1
'q' -> leaveMainLoop
_ -> return ()
postRedisplay Nothing
A part of a solution
In fact, I have found a solution in order to "freeze" the voxel:
voxel :: Voxel
{-# NOINLINE voxel #-}
voxel = unsafePerformIO $ makeVoxel fBretzel5 ((-2.5,2.5),(-2.5,2.5),(-0.5,0.5))
trianglesBretz :: Double -> IO [Triangle]
trianglesBretz level =
computeContour3d voxel level
In this way, I think the voxel is never re-evaluated.
But there is still a problem. When the IORef rot changes, to rotate the graphics, then there's no reason to re-evaluate trianglesBretz: the triangular mesh of f(x,y,z)=level is always the same whatever the rotation.
So, how can I say to the display function: "hey! when rot changes, do not re-evaluate trianglesBretz, since you will find the same result" ?
I don't know how to use NOINLINE for trianglesBretz, as I did for voxel. Something which would "freezes" trianglesBretz level unless level changes.
And here is the 5-holes bretzel:
EDIT: solution based on #Petr Pudlák's answer.
After #Petr Pudlák's very good answer I came to the following code. I give this solution here in order to place the answer more in the context of OpenGL.
data Context = Context
{
contextRotation :: IORef Float
, contextTriangles :: IORef [Triangle]
}
red :: Color4 GLfloat
red = Color4 1 0 0 1
fBretz :: XYZ -> Double
fBretz (x,y,z) = ((x2+y2/4-1)*(x2/4+y2-1))^2 + z*z
where
x2 = x*x
y2 = y*y
voxel :: Voxel
{-# NOINLINE voxel #-}
voxel = unsafePerformIO $ makeVoxel fBretz ((-2.5,2.5),(-2.5,2.5),(-1,1))
trianglesBretz :: Double -> IO [Triangle]
trianglesBretz level = computeContour3d voxel level
display :: Context -> DisplayCallback
display context = do
clear [ColorBuffer, DepthBuffer]
rot <- get (contextRotation context)
triangles <- get (contextTriangles context)
loadIdentity
rotate rot $ Vector3 1 0 0
renderPrimitive Triangles $ do
materialDiffuse FrontAndBack $= red
mapM_ drawTriangle triangles
swapBuffers
where
drawTriangle (v1,v2,v3) = do
triangleNormal (v1,v2,v3) -- the normal of the triangle
vertex v1
vertex v2
vertex v3
keyboard :: IORef Float -- rotation angle
-> IORef Double -- isolevel
-> IORef [Triangle] -- triangular mesh
-> KeyboardCallback
keyboard rot level trianglesRef c _ = do
case c of
'e' -> rot $~! subtract 2
'r' -> rot $~! (+ 2)
'h' -> do
l $~! (+ 0.1)
l' <- get l
triangles <- trianglesBretz l'
writeIORef trianglesRef triangles
'n' -> do
l $~! (- 0.1)
l' <- get l
triangles <- trianglesBretz l'
writeIORef trianglesRef triangles
'q' -> leaveMainLoop
_ -> return ()
postRedisplay Nothing
main :: IO ()
main = do
_ <- getArgsAndInitialize
_ <- createWindow "Bretzel"
windowSize $= Size 500 500
initialDisplayMode $= [RGBAMode, DoubleBuffered, WithDepthBuffer]
clearColor $= white
materialAmbient FrontAndBack $= black
lighting $= Enabled
lightModelTwoSide $= Enabled
light (Light 0) $= Enabled
position (Light 0) $= Vertex4 0 0 (-100) 1
ambient (Light 0) $= black
diffuse (Light 0) $= white
specular (Light 0) $= white
depthFunc $= Just Less
shadeModel $= Smooth
rot <- newIORef 0.0
level <- newIORef 0.1
triangles <- trianglesBretz 0.1
trianglesRef <- newIORef triangles
displayCallback $= display Context {contextRotation = rot,
contextTriangles = trianglesRef}
reshapeCallback $= Just yourReshapeCallback
keyboardCallback $= Just (keyboard rot level trianglesRef)
idleCallback $= Nothing
putStrLn "*** Bretzel ***\n\
\ To quit, press q.\n\
\ Scene rotation:\n\
\ e, r, t, y, u, i\n\
\ Increase/Decrease level: h, n\n\
\"
mainLoop
And now my bretzel can be rotated without performing useless calculations.
I'm not very familiar with OpenGL, so I have some difficulty understanding the code in detail - please correct me if I misunderstood something.
I'd try to abstain from using unsafe functions or relying on INLINE as much as possible. This usually makes code brittle and obscures more natural solutions.
In the simplest case, if you don't need to re-evaluate triangularize, we could just replace it with its output. So we'd have
data Context = Context
{ contextRotation :: IORef Float,
, contextTriangles :: [Triangle]
}
and then
display :: Context -> DisplayCallback
which won't reevaluate triangles at all, they'll be computed only once when Context is created.
Now if there are two parameters, rotation and level, and triangles depend on the level, but not on rotation: The trick here would be to manage dependencies properly. Now we expose the storage for parameters explicitly (IORef Float), and as a consequence, we can't monitor when the value inside changes. But the caller doesn't need to know the representation of how the parameters are stored. It just needs to store them somehow. So instead, let's have
data Context = Context
{ contextRotation :: IORef Float,
, contextTriangles :: IORef [Triangle]
}
and
setLevel :: Context -> Float -> IO ()
That is, we expose a function to store the parameter, but we hide the internals. Now we can implement it as:
setLevel (Context _ trianglesRef) level = do
let newTriangles = ... -- compute the new triangles
writeIORef trianglesRef newTriangles
And as triangles don't depend on the rotation parameter, we can have just:
setRotation :: Context -> Float -> IO ()
setRoration (Context rotationRef _) = writeIORef rotationRef
Now the dependencies are hidden for callers. They can set the level or the rotation, without knowing what depends on them. At the same time, triangles are updated when needed (level changes), and only then. And Haskell's lazy evaluation gives a nice bonus: If the level changes multiple times before the triangles are needed, they are not evaluated. The [Triangle] thunk inside the IORef will be only evaluated when requested by display.
I want to access the pixel data of what is being displayed to the window, but I have not had any luck finding such a function in gloss, nor by attempting to call OpenGL readPixels in a keyboard event callback. It looks like gloss renders a Picture to the window without exposing the rendered bitmap.
If this is hard to do in gloss, is there an alternative which has realtime high-level bitmap manipulation (translation, rotation, transparency)?
It turns out readPixels can be used in this case. I found this snippet while digging through #haskell chat logs:
-- save a screenshot to a handle as binary PPM
snapshotWith :: (BS.ByteString -> IO b) -> Position -> Size -> IO b
snapshotWith f p0 vp#(Size vw vh) = do
let fi q = fromIntegral q
p6 = "P6\n" ++ show vw ++ " " ++ show vh ++ " 255\n"
allocaBytes (fi (vw*vh*3)) $ \ptr -> do
readPixels p0 vp $ PixelData RGB UnsignedByte ptr
px <- BSI.create (fi $ vw * vh * 3) $ \d -> forM_ [0..vh-1] $ \y ->
BSI.memcpy
(d`plusPtr`fi(y*vw*3))
(ptr`plusPtr`fi ((vh-1-y)*vw*3))
(fi(vw*3))
f $ BS.pack (map (toEnum . fromEnum) p6) `BS.append` px
writeSnapshot :: FilePath -> Position -> Size -> IO ()
writeSnapshot f = snapshotWith (BS.writeFile f)
From https://gitorious.org/maximus/mandulia/source/58695617c322b0b37ec72f9a0bd3eed8308bf700:src/Snapshot.hs
Recently a new package gloss-export was released with the appropriate purpose:
Export gloss pictures as PNG, Bitmap, TGA, TIFF, Gif
I once had the same problem and couldn't find a good solution, so my answer probably won't be appropriate. My workaround was to use bmp package, deal with the BMP content manually (via ByteString manipulation), and then convert it to a glossy bitmap with bitmapOfBMP. For example, this was a function for blending a bitmap with a color:
recolor :: (Float, Float, Float) -> BMP -> BMP
recolor (rc, gc, bc) bmp#BMP {bmpRawImageData = raw} =
bmp {bmpRawImageData = B.pack $ process $ B.unpack raw} where
process (b:g:r:a:xs) = (mul b bc):(mul g gc):(mul r rc):a:process xs
process xs = xs
mul c cc = round $ cc * fromIntegral c
This was enough for me in that time, so I stopped finding a better solution. If you'll find something, please share.
Given the following:
integralB :: Num a => Behavior t a -> Behavior t a -- definite integral of a behaviour
eJump :: Event t a -- tells the player to jump
bYAccel = pure 4000 -- y acceleration
bYVel = integralB bYAccel -- y velocity
bY = integralB bYVel -- y position
How do I make the player jump (probably by setting its y velocity) when a jump event arrives?
You'll need to be able to apply an impulse to the Y velocity for the jump. From your own answer, you've come up with a way to do so by summing all the impulses from the jumps and adding them to the integral of the acceleration.
Your acceleration is also constant. If you don't want the player falling constantly, you'd need something like:
bYAccel = (ifB airborne) 4000 0
airborne = fmap (>0) bY
ifB :: Behavior t Bool -> a -> a -> Behavior t a
ifB boolBehavior yes no = fmap (\bool -> if bool then yes else no) boolBehavior
One possible reason the height of your jumps varies is you aren't resetting the velocity when the player lands. If you have rules that hold the player above some position (like the floor), and are somehow stopping acceleration when the player hits the floor, you will also need to set the velocity to 0 if it is in the direction of the floor. (If you also set it to 0 when it's not in the direction of the floor, the player can never get the velocity to leave the ground.)
The reason this would cause erratic jumping heights is that the final velocity when the player lands will be close to the impulse you applied for them to take off. Using your numbers, if a jump started with a velocity of -5000, and ended with a velocity of 4800, the next jump will add an impulse of -5000, taking the jump to a starting velocity of only -200. That might have an ending velocity of 300, so the next jump will be an almost full -4700 jump.
Here's a complete working example. It uses the gloss library for input and display. The gameDefinition corresponds to the components introduced in your question. integrateDeltas is equivalent to your integralB, but produces events that are impulses, which are easy to generate in a clocked framework like gloss, and easy to use mixed with other events that cause impulses, like jumping.
{-# LANGUAGE RankNTypes #-}
module Main where
import Reactive.Banana
import Reactive.Banana.Frameworks.AddHandler
import Reactive.Banana.Frameworks
import Data.IORef
import qualified Graphics.Gloss.Interface.IO.Game as Gloss
gameDefinition :: GlossGameEvents t -> Behavior t Gloss.Picture
gameDefinition events = renderBehavior
where
bY = accumB 0 (fmap sumIfPositive yShifts)
yShifts = integrateDeltas bYVel
bYVel = accumB 0 yVelChanges
yVelChanges = apply ((ifB airborne) (+) sumIfPositive) yVelShifts
yVelShifts = union (integrateDeltas bYAccel) (fmap (const 3) eJump)
bYAccel = (ifB airborne) (-10) 0
airborne = fmap (>0) bY
eJump = filterE isKeyEvent (event events)
integrateDeltas = integrateDeltaByTimeStep (timeStep events)
renderBehavior = (liftA3 render) bY bYVel bYAccel
render y yVel yAccel =
Gloss.Pictures [
Gloss.Translate 0 (20+y*100) (Gloss.Circle 20),
Gloss.Translate (-50) (-20) (readableText (show y)),
Gloss.Translate (-50) (-40) (readableText (show yVel)),
Gloss.Translate (-50) (-60) (readableText (show yAccel))
]
readableText = (Gloss.Scale 0.1 0.1) . Gloss.Text
-- Utilities
sumIfPositive :: (Ord n, Num n) => n -> n -> n
sumIfPositive x y = max 0 (x + y)
ifB :: Behavior t Bool -> a -> a -> Behavior t a
ifB boolBehavior yes no = fmap (\bool -> if bool then yes else no) boolBehavior
integrateDeltaByTimeStep :: (Num n) => Event t n -> Behavior t n -> Event t n
integrateDeltaByTimeStep timeStep derivative = apply (fmap (*) derivative) timeStep
isKeyEvent :: Gloss.Event -> Bool
isKeyEvent (Gloss.EventKey _ _ _ _) = True
isKeyEvent _ = False
-- Main loop to run it
main :: IO ()
main = do
reactiveGame (Gloss.InWindow "Reactive Game Example" (400, 400) (10, 10))
Gloss.white
100
gameDefinition
-- Reactive gloss game
data GlossGameEvents t = GlossGameEvents {
event :: Event t Gloss.Event,
timeStep :: Event t Float
}
makeReactiveGameNetwork :: Frameworks t
=> IORef Gloss.Picture
-> AddHandler Gloss.Event
-> AddHandler Float
-> (forall t. GlossGameEvents t -> Behavior t Gloss.Picture)
-> Moment t ()
makeReactiveGameNetwork latestFrame glossEvent glossTime game = do
eventEvent <- fromAddHandler glossEvent
timeStepEvent <- fromAddHandler glossTime
let
events = GlossGameEvents { event = eventEvent, timeStep = timeStepEvent }
pictureBehavior = game events
pictureChanges <- changes pictureBehavior
reactimate (fmap (writeIORef latestFrame) pictureChanges)
reactiveGame :: Gloss.Display
-> Gloss.Color
-> Int
-> (forall t. GlossGameEvents t -> Behavior t Gloss.Picture)
-> IO ()
reactiveGame display color steps game = do
latestFrame <- newIORef Gloss.Blank
(glossEvent, fireGlossEvent) <- newAddHandler
(glossTime, addGlossTime) <- newAddHandler
network <- compile (makeReactiveGameNetwork latestFrame glossEvent glossTime game)
actuate network
Gloss.playIO
display
color
steps
()
(\world -> readIORef latestFrame)
(\event world -> fireGlossEvent event)
(\time world -> addGlossTime time)
In this example, bY checks for collision with a floor at 0 by accumulating the impulses, but constraining the accumulated value to be above 0.
The velocity, bYVel, accumulates all impulses while airborne, but only those impulses that are directed away from the floor while not airborne. If you change
yVelChanges = apply ((ifB airborne) (+) sumIfPositive) yVelShifts
to
yVelChanges = fmap (+) yVelShifts
it recreates the erratic jumping bug.
The acceleration, bYAccel, is only present while airborne.
I used a coordinate system with a +Y axis in the up direction (opposite the acceleration).
The code at the end is a small framework to hook reactive-banana up to gloss.
Solved it! I feel a little silly for not thinking of this earlier, but I just increment a counter every eJump and add that counter on to bYVel.
bJumpVel = sumB $ (-5000) <$ eJump
bYVel = (+) <$> bJumpVel <*> integralB bYAccel
-- gives the sum of the events
sumB :: Num a => Event t a -> Behavior t a
sumB e = accumB 0 $ (+) <$> e
For some reason the height of the jump always varies quite a bit, but that's probably an unrelated problem to do with my timing of things.
I won't mark this question as answered yet in case someone wants to share a better one.
When I create two windows and redraw them in two different threads (one per window), it seems like all drawing goes to first created window. It constantly switches between what should be displayed in both windows. And second one remains mostly black.
The code was working well with only one window, and then I updated it - inserted currentWindow $= Just glWindow in the beginning of the functions which set callbacks and call rendering methods.
What do you think is the cause of the problems?
EDIT:
Code skeleton:
module Chart.Window where
import Graphics.UI.GLUT hiding (Window, postRedisplay, <etc>)
import qualified Graphics.UI.GLUT as GLUT
import qualified Graphics.Rendering.OpenGL as GL
data Window = Window
{ glWindow :: GLUT.Window
, viewListRef :: IORef [Line]
}
main = do
forkOS start <params1>
forkOS start <params2>
start <params> = do
win <- new <params>
run win
mainLoop
new :: Strict -> (Int, Int) -> (Int, Int) -> IO Window
new name (posx, posy) (w, h) = do
initGLUT
glWindow <- createWindow name
currentWindow $= Just glWindow
windowSize $= Size (fromIntegral w) (fromIntegral h)
windowPosition $= Position (fromIntegral posx) (fromIntegral posy)
return Window {..}
initGLUT :: IO ()
initGLUT = do
beenInit <- get initState
unless beenInit $ void getArgsAndInitialize
initialDisplayMode $= [WithDepthBuffer, DoubleBuffered, RGBAMode]
initialWindowSize $= Size 100 100
initialWindowPosition $= Position 100 100
actionOnWindowClose $= ContinueExectuion
run :: Window -> IO ()
run win#Window{..} = do
-- this will fork (with forkIO) threads
-- which will call "repaint" when chart needs to be updated
initListeners repaint
initCallbacks win
where
repaint :: [Line] -> IO ()
repaint viewList = do
writeIORef viewListRef viewList
postRedisplay win
postRedisplay Window{..} = GLUT.postRedisplay $ Just glWindow
initCallbacks win#Window{..} = do
currentWindow $= Just glWindow
GLUT.displayCallback $= display win
GLUT.idleCallback $= Just (postRedisplay win)
display Window{..} = do
currentWindow $= Just glWindow
Size w h <- get windowSize
viewList <- readIORef viewListRef
drawChart viewList otherOptions
reshapeCallback :: Window -> GLUT.ReshapeCallback
reshapeCallback win#Window{..} size#(Size w h) = do
currentWindow $= Just glWindow
GL.viewport $= (Position 0 0, size)
GL.matrixMode $= GL.Projection
GL.loadIdentity
GL.ortho2D 0 (fromIntegral w) 0 (fromIntegral h)
GL.matrixMode $= GL.Modelview 0
GL.loadIdentity
... -- send command for listener thread to change internal state and postRedisplay
drawChart viewList otherOptions = do
...
-- chart consists of several horizontal panels. Call this for each panel:
glViewport 0 panelYPosition width winHeight
glScissor 0 panelYPosition (fromIntegral width) (fromIntegral panelHeight)
GL.clear [GL.ColorBuffer]
...
-- and then for each line=(Vertex2 v1 v2) from viewList
GL.renderPrimitive GL.Lines $ do
GL.vertex v1
GL.vertex v2
...
BTW, when I commented the line which sets reshapeCallback (and window is reshaped at the beginning) and launched charting with only one window, I got exactly the same effect as in multi-window launch. I mean, the (only) window was mostly empty as if it was secondly created.
I had a similar problem. I work with a thread that calculates the iterations of a genetic algorithm and in each iteration I call to "GL.postRedisplay (Just window)" but it didn't draw anything.
I solved my problem by calling "GL.postRedisplay (Just window)" from the idle function:
idle window = CC.threadDelay (1000*500) >> GL.postRedisplay (Just window)
Don't forget to setup your idle callback function like this:
GL.idleCallback GL.$= Just (idle window) >>
CC and GL mean:
import qualified Control.Concurrent as CC
import qualified Graphics.UI.GLUT as GL