-- -- This code was created by Jeff Molofee '99 (ported to Haskell GHC 2005) -- module Main where import Graphics.UI.GLUT import System.Exit ( exitWith, ExitCode(..) ) import Data.IORef ( IORef, newIORef, writeIORef ) import Util ( Image(..), bitmapLoad ) import Monad ( when, liftM ) import Random data Star = Star { starColor :: Color3 GLubyte, starDist, starAngle :: GLfloat } deriving Show numStars :: Num a => a numStars = 50 initGL :: IO TextureObject initGL = do tex <- loadGLTextures texture Texture2D $= Enabled clearColor $= Color4 0 0 0 0.5 -- Clear the background color to black clearDepth $= 1 -- enables clearing of the depth buffer depthFunc $= Nothing -- type of depth test shadeModel $= Smooth -- enables smooth color shading matrixMode $= Projection hint PerspectiveCorrection $= Nicest blendFunc $= (SrcAlpha, One) blend $= Enabled loadIdentity -- reset projection matrix Size width height <- get windowSize perspective 45 (fromIntegral width/fromIntegral height) 0.1 100 -- calculate the aspect ratio of the window matrixMode $= Modelview 0 flush -- finally, we tell opengl to do it. return tex generateStars :: IO [IORef Star] generateStars = mapM (\i -> do r <- getStdRandom (randomR (0, 255)) :: IO Int g <- getStdRandom (randomR (0, 255)) :: IO Int b <- getStdRandom (randomR (0, 255)) :: IO Int newIORef (Star {starAngle = 0, starColor = Color3 (fromIntegral r) (fromIntegral g) (fromIntegral b), starDist = (i/numStars)*5})) [0..numStars-1] loadGLTextures :: IO TextureObject loadGLTextures = do (Image (Size w h) pd) <- bitmapLoad "Data/Star.bmp" texName <- liftM head (genObjectNames 1) textureBinding Texture2D $= Just texName textureFilter Texture2D $= ((Linear', Nothing), Linear') texImage2D Nothing NoProxy 0 RGB' (TextureSize2D w h) 0 pd return texName resizeScene :: Size -> IO () resizeScene (Size w 0) = resizeScene (Size w 1) -- prevent divide by zero resizeScene s@(Size width height) = do viewport $= (Position 0 0, s) matrixMode $= Projection loadIdentity perspective 45 (fromIntegral width/fromIntegral height) 0.1 100 matrixMode $= Modelview 0 flush colorUpgrade :: Color3 a -> a -> Color4 a colorUpgrade (Color3 r g b) a = Color4 r g b a drawScene :: TextureObject -> IORef GLfloat -> IORef GLfloat -> IORef Bool -> IORef GLfloat -> [IORef Star] -> IO () drawScene tex zoom tilt twinkle spin stars = do clear [ColorBuffer, DepthBuffer] -- clear the screen and the depth bufer textureBinding Texture2D $= Just tex mapM_ ( \(st1, st2, i) -> do loadIdentity s1 <- get st1 s2 <- get st2 sp <- get spin zo <- get zoom ti <- get tilt tw <- get twinkle translate (Vector3 0 0 (zo::GLfloat)) rotate ti (Vector3 1 0 (0::GLfloat)) rotate (starAngle s1) (Vector3 0 1 (0::GLfloat)) translate (Vector3 (starDist s1) 0 (0::GLfloat)) rotate (-(starAngle s1)) (Vector3 0 1 (0::GLfloat)) rotate (-ti) (Vector3 1 0 (0::GLfloat)) when tw $ do color (colorUpgrade (starColor s2) 255) renderPrimitive Quads $ do texCoord (TexCoord2 0 (0::GLfloat)) vertex (Vertex3 (-1) (-1) (0::GLfloat)) texCoord (TexCoord2 1 (0::GLfloat)) vertex (Vertex3 1 (-1) (0::GLfloat)) texCoord (TexCoord2 1 (1::GLfloat)) vertex (Vertex3 1 1 (0::GLfloat)) texCoord (TexCoord2 0 (1::GLfloat)) vertex (Vertex3 (-1) 1 (0::GLfloat)) rotate sp (Vector3 0 0 (1::GLfloat)) color (colorUpgrade (starColor s1) 255) renderPrimitive Quads $ do texCoord (TexCoord2 0 (0::GLfloat)) vertex (Vertex3 (-1) (-1) (0::GLfloat)) texCoord (TexCoord2 1 (0::GLfloat)) vertex (Vertex3 1 (-1) (0::GLfloat)) texCoord (TexCoord2 1 (1::GLfloat)) vertex (Vertex3 1 1 (0::GLfloat)) texCoord (TexCoord2 0 (1::GLfloat)) vertex (Vertex3 (-1) 1 (0::GLfloat)) spin $= sp + 0.01 if starDist s1 < 0 then do d <- return ((starDist s1)+5) r <- getStdRandom (randomR (0, 255)) :: IO Int g <- getStdRandom (randomR (0, 255)) :: IO Int b <- getStdRandom (randomR (0, 255)) :: IO Int st1 $= Star { starAngle = (starAngle s1) + i/numStars, starColor = Color3 (fromIntegral r) (fromIntegral g) (fromIntegral b), starDist = d } else do st1 $= Star { starAngle = (starAngle s1) + i/numStars, starColor = (starColor s1), starDist = (starDist s1)-0.01 }) (zip3 stars (reverse stars) [0..numStars-1]) -- finally the second parameter to mapM_ -- since this is double buffered, swap the buffers to display what was just -- drawn flush swapBuffers keyPressed :: IORef Bool -> IORef GLfloat -> IORef GLfloat -> KeyboardMouseCallback -- 27 is ESCAPE keyPressed _ _ _ (Char '\27') Down _ _ = exitWith ExitSuccess keyPressed t _ _ (Char 'T') Down _ _ = do twinkle <- get t if twinkle then t $= False else t $= True keyPressed tw zo ti (Char 't') Down x y = keyPressed tw zo ti (Char 'T') Down x y keyPressed _ zoom _ (SpecialKey KeyPageUp) Down _ _ = get zoom >>= writeIORef zoom . (subtract 0.2) keyPressed _ zoom _ (SpecialKey KeyPageDown) Down _ _ = get zoom >>= writeIORef zoom . (+0.2) keyPressed _ _ tilt (SpecialKey KeyUp) Down _ _ = get tilt >>= writeIORef tilt . (subtract 0.5) keyPressed _ _ tilt (SpecialKey KeyDown) Down _ _ = get tilt >>= writeIORef tilt . (+ 0.5) keyPressed _ _ _ _ _ _ _ = do return () main :: IO () main = do -- Initialize GLUT state - glut will take any command line arguments -- that pertain to it or X windows -- look at its documentation at -- http://reality.sgi.com/mjk/spec3/spec3.html getArgsAndInitialize -- select type of display mode: -- Double buffer -- RGBA color -- Alpha components supported -- Depth buffer initialDisplayMode $= [ DoubleBuffered, RGBAMode, WithDepthBuffer, WithAlphaComponent ] -- get an 800 x 600 window initialWindowSize $= Size 800 600 -- window starts at upper left corner of the screen initialWindowPosition $= Position 0 0 -- open a window createWindow "Jeff Molofee's GL Code Tutorial ... NeHe '99" -- register the function to do all our OpenGL drawing twinkle <- newIORef False spin <- newIORef 0 stars <- generateStars zoom <- newIORef (-15) tilt <- newIORef 90 -- initialize our window. tex <- initGL displayCallback $= (drawScene tex zoom tilt twinkle spin stars) -- go fullscreen. This is as soon as possible. fullScreen -- even if there are no events, redraw our gl scene idleCallback $= Just (drawScene tex zoom tilt twinkle spin stars) -- register the funciton called when our window is resized reshapeCallback $= Just resizeScene -- register the function called when the keyboard is pressed. keyboardMouseCallback $= Just (keyPressed twinkle zoom tilt) -- start event processing engine mainLoop