--
-- 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, modifyIORef )
import Util ( Image(..), bitmapLoad )
import Monad ( liftM )
boxcol :: [Color3 GLfloat]
boxcol = [Color3 1 0 0, Color3 1 0.5 0, Color3 1 1 0,
Color3 0 1 0, Color3 0 1 1]
topcol :: [Color3 GLfloat]
topcol = [Color3 0.5 0 0, Color3 0.5 0.25 0, Color3 0.5 0.5 0,
Color3 0 0.5 0, Color3 0 0.5 0.5]
buildLists :: IO (DisplayList, DisplayList)
buildLists = do
box <- defineNewList Compile $
do renderPrimitive Quads $
do { texCoord (TexCoord2 1 (1::GLfloat)); vertex (Vertex3 (-1) (-1) (-1::GLfloat));
texCoord (TexCoord2 0.0 (1.0::GLfloat)); vertex(Vertex3 1.0 (-1.0) (-1.0::GLfloat)); -- Top Left Of The Texture and Quad
texCoord (TexCoord2 0.0 (0.0::GLfloat)); vertex(Vertex3 1.0 (-1.0) (1.0::GLfloat)); -- Bottom Left Of The Texture and Quad
texCoord (TexCoord2 1.0 (0.0::GLfloat)); vertex(Vertex3(-1.0) (-1.0) (1.0::GLfloat)); -- Bottom Right Of The Texture and Quad
-- Front Face
texCoord (TexCoord2 0.0 (0.0::GLfloat)); vertex(Vertex3(-1.0) (-1.0) (1.0::GLfloat)); -- Bottom Left Of The Texture and Quad
texCoord (TexCoord2 1.0 (0.0::GLfloat)); vertex(Vertex3 1.0 (-1.0) (1.0::GLfloat)); -- Bottom Right Of The Texture and Quad
texCoord (TexCoord2 1.0 (1.0::GLfloat)); vertex(Vertex3 1.0 1.0 (1.0::GLfloat)); -- Top Right Of The Texture and Quad
texCoord (TexCoord2 0.0 (1.0::GLfloat)); vertex(Vertex3(-1.0) 1.0 (1.0::GLfloat)); -- Top Left Of The Texture and Quad
-- Back Face
texCoord (TexCoord2 1.0 (0.0::GLfloat)); vertex(Vertex3(-1.0) (-1.0) (-1.0::GLfloat)); -- Bottom Right Of The Texture and Quad
texCoord (TexCoord2 1.0 (1.0::GLfloat)); vertex(Vertex3(-1.0) 1.0 (-1.0::GLfloat)); -- Top Right Of The Texture and Quad
texCoord (TexCoord2 0.0 (1.0::GLfloat)); vertex(Vertex3 1.0 1.0 (-1.0::GLfloat)); -- Top Left Of The Texture and Quad
texCoord (TexCoord2 0.0 (0.0::GLfloat)); vertex(Vertex3 1.0 (-1.0) (-1.0::GLfloat)); -- Bottom Left Of The Texture and Quad
-- Right face
texCoord (TexCoord2 1.0 (0.0::GLfloat)); vertex(Vertex3 1.0 (-1.0) (-1.0::GLfloat)); -- Bottom Right Of The Texture and Quad
texCoord (TexCoord2 1.0 (1.0::GLfloat)); vertex(Vertex3 1.0 1.0 (-1.0::GLfloat)); -- Top Right Of The Texture and Quad
texCoord (TexCoord2 0.0 (1.0::GLfloat)); vertex(Vertex3 1.0 1.0 (1.0::GLfloat)); -- Top Left Of The Texture and Quad
texCoord (TexCoord2 0.0 (0.0::GLfloat)); vertex(Vertex3 1.0 (-1.0) (1.0::GLfloat)); -- Bottom Left Of The Texture and Quad
-- Left Face
texCoord (TexCoord2 0.0 (0.0::GLfloat)); vertex(Vertex3(-1.0) (-1.0) (-1.0::GLfloat)); -- Bottom Left Of The Texture and Quad
texCoord (TexCoord2 1.0 (0.0::GLfloat)); vertex(Vertex3(-1.0) (-1.0) (1.0::GLfloat)); -- Bottom Right Of The Texture and Quad
texCoord (TexCoord2 1.0 (1.0::GLfloat)); vertex(Vertex3(-1.0) 1.0 (1.0::GLfloat)); -- Top Right Of The Texture and Quad
texCoord (TexCoord2 0.0 (1.0::GLfloat)); vertex(Vertex3(-1.0) 1.0 (-1.0::GLfloat));} -- Top Left Of The Texture and Quad
top <- defineNewList Compile $
do renderPrimitive Quads $
do { texCoord (TexCoord2 0 (1::GLfloat)); vertex (Vertex3 (-1) 1 (-1::GLfloat));
texCoord (TexCoord2 0 (0::GLfloat)); vertex (Vertex3 (-1) 1 (1::GLfloat));
texCoord (TexCoord2 1 (0::GLfloat)); vertex (Vertex3 1 1 (1::GLfloat));
texCoord (TexCoord2 1 (1::GLfloat)); vertex (Vertex3 1 1 (-1::GLfloat)); }
return (box, top)
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 $= Just Less -- type of depth test
shadeModel $= Smooth -- enables smooth color shading
matrixMode $= Projection
hint PerspectiveCorrection $= Nicest
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
light (Light 0) $= Enabled
lighting $= Enabled
colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)
flush -- finally, we tell opengl to do it.
return tex
loadGLTextures :: IO TextureObject
loadGLTextures = do
(Image (Size w h) pd) <- bitmapLoad "Data/cube.bmp"
texName <- liftM head (genObjectNames 1)
textureBinding Texture2D $= Just texName
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
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
drawScene :: TextureObject -> IORef GLfloat -> IORef GLfloat
-> DisplayList -> DisplayList -> IO ()
drawScene tex xrot yrot box top = do
clear [ColorBuffer, DepthBuffer] -- clear the screen and the depth bufer
textureBinding Texture2D $= Just tex
xr <- get xrot
yr <- get yrot
mapM_ (\(x,y) ->
do { loadIdentity;
let {x' = fromIntegral x;
y' = fromIntegral y };
translate (Vector3 (1.4+x'*2.8-y'*1.4) (((6-y')*2.4)-7) (-20::GLfloat));
rotate (45.0-(2.0*y')+xr) (Vector3 1 0 (0::GLfloat));
rotate (45-yr) (Vector3 0 1 (0::GLfloat));
color (boxcol !! (y-1));
callList box;
color (topcol !! (y-1));
callList top } ) [(x,y) | y <- [1..5], x <- [0..y-1] ]
-- since this is double buffered, swap the buffers to display what was just
-- drawn
flush
swapBuffers
keyPressed :: IORef GLfloat -> IORef GLfloat -> KeyboardMouseCallback
-- 27 is ESCAPE
keyPressed _ _ (Char '\27') Down _ _ = exitWith ExitSuccess
keyPressed xrot _ (SpecialKey KeyUp) Down _ _ = modifyIORef xrot (subtract 0.8)
keyPressed xrot _ (SpecialKey KeyDown) Down _ _ = modifyIORef xrot (+0.8)
keyPressed _ yrot (SpecialKey KeyLeft) Down _ _ = modifyIORef yrot (subtract 0.8)
keyPressed _ yrot (SpecialKey KeyRight) Down _ _ = modifyIORef yrot (+0.8)
keyPressed _ _ _ _ _ _ = 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
xrot <- newIORef 0
yrot <- newIORef 0
-- initialize our window.
tex <- initGL
(box, top) <- buildLists
displayCallback $= (drawScene tex xrot yrot box top)
-- go fullscreen. This is as soon as possible.
fullScreen
-- even if there are no events, redraw our gl scene
idleCallback $= Just (drawScene tex xrot yrot box top)
-- register the funciton called when our window is resized
reshapeCallback $= Just resizeScene
-- register the function called when the keyboard is pressed.
keyboardMouseCallback $= Just (keyPressed xrot yrot)
-- start event processing engine
mainLoop