{- Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc) This file is part of HOpenGL - a binding of OpenGL and GLUT for Haskell. Copyright (C) 2000 Sven Panne This program demonstrates the use of the OpenGL lighting model. A sphere is drawn using a grey material characteristic. A single light source illuminates the object. --------------------------------------------------------------------------- HOpenGL Tutorial http://www.cin.ufpe.br/~hopengl/ Copyright (C) 2002 Andre Furtado This code is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. This is a HOpenGL example. -} import GL import GLUT import IOExts foreign import shutdownHaskellAndExit :: Int -> IO () -- Initialize material property, light source, lighting model, -- and depth buffer. myInit :: IO () myInit = do clearColor (Color4 0.0 0.0 0.0 0.0) shadeModel Smooth light (Light 0) (Position (Vertex4 1.0 1.0 1.0 0.0)) light (Light 0) (LightColor Ambient (Color4 1.0 1.0 1.0 0.0)) enable Lighting enable (Light 0) enable DepthTest enable Blend' blendFunc SrcAlpha OneMinusSrcAlpha idle :: IORef GLfloat -> (IORef GLfloat, IORef GLfloat, IORef GLfloat, IORef GLfloat) -> (IORef GLfloat, IORef GLfloat, IORef GLfloat, IORef GLfloat) -> (IORef GLfloat, IORef GLfloat, IORef GLfloat, IORef GLfloat) -> (IORef GLfloat, IORef GLfloat, IORef GLfloat, IORef GLfloat) -> IORef GLfloat -> IdleAction idle angle (sp1, sp2, sp3, sp4) (d1, d2, d3, d4) (a1, a2, a3, a4) (e1, e2, e3, e4) sh = do alpha <- readIORef angle a <- readIORef sp1 b <- readIORef sp2 c <- readIORef sp3 d <- readIORef sp4 e <- readIORef d1 f <- readIORef d2 g <- readIORef d3 h <- readIORef d4 i <- readIORef a1 j <- readIORef a2 k <- readIORef a3 l <- readIORef a4 m <- readIORef e1 n <- readIORef e2 o <- readIORef e3 p <- readIORef e4 q <- readIORef sh clear [ ColorBufferBit, DepthBufferBit ] mapM_ (material Front) [ MaterialColor Specular (Color4 a b c d), MaterialColor Diffuse (Color4 e f g h), MaterialColor Ambient (Color4 i j k l), MaterialColor Emission (Color4 m n o p), Shininess q] rotate alpha (Vector3 1.0 1.0 1.0) updateIORef angle (\s -> s + 0.02) solidSphere 1.0 20 16 swapBuffers flush reshape :: ReshapeAction reshape screenSize@(WindowSize w h) = do viewport (WindowPosition 0 0) screenSize matrixMode Projection loadIdentity let wf = fromIntegral w hf = fromIntegral h if (w <= h) then ortho (-1.5) 1.5 (-1.5*hf/wf) (1.5*hf/wf) (-10.0) 10.0 else ortho (-1.5*wf/hf) (1.5*wf/hf) (-1.5) 1.5 (-10.0) 10.0 matrixMode Modelview loadIdentity special :: (IORef GLfloat, IORef GLfloat, IORef GLfloat, IORef GLfloat) -> SpecialAction special (e1, e2, e3, e4) x _ = case x of KeyF1 -> updateIORef e1 (\s -> s + 0.1) >> postRedisplay KeyF2 -> updateIORef e1 (\s -> s - 0.1) >> postRedisplay KeyF3 -> updateIORef e2 (\s -> s + 0.1) >> postRedisplay KeyF4 -> updateIORef e2 (\s -> s - 0.1) >> postRedisplay KeyF5 -> updateIORef e3 (\s -> s + 0.1) >> postRedisplay KeyF6 -> updateIORef e3 (\s -> s - 0.1) >> postRedisplay KeyF7 -> updateIORef e4 (\s -> s + 0.1) >> postRedisplay KeyF8 -> updateIORef e4 (\s -> s - 0.1) >> postRedisplay _ -> return () keyboard :: (IORef GLfloat, IORef GLfloat, IORef GLfloat, IORef GLfloat) -> (IORef GLfloat, IORef GLfloat, IORef GLfloat, IORef GLfloat) -> (IORef GLfloat, IORef GLfloat, IORef GLfloat, IORef GLfloat) -> IORef GLfloat -> KeyboardAction keyboard (sp1, sp2, sp3, sp4) (d1, d2, d3, d4) (a1, a2, a3, a4) sh x _ = case x of 'q' -> updateIORef sp1 (\s -> s + 0.1) >> postRedisplay 'w' -> updateIORef sp1 (\s -> s - 0.1) >> postRedisplay 'e' -> updateIORef sp2 (\s -> s + 0.1) >> postRedisplay 'r' -> updateIORef sp2 (\s -> s - 0.1) >> postRedisplay 't' -> updateIORef sp3 (\s -> s + 0.1) >> postRedisplay 'y' -> updateIORef sp3 (\s -> s - 0.1) >> postRedisplay 'u' -> updateIORef sp4 (\s -> s + 0.1) >> postRedisplay 'i' -> updateIORef sp4 (\s -> s - 0.1) >> postRedisplay 'a' -> updateIORef d1 (\s -> s + 0.1) >> postRedisplay 's' -> updateIORef d1 (\s -> s - 0.1) >> postRedisplay 'd' -> updateIORef d2 (\s -> s + 0.1) >> postRedisplay 'f' -> updateIORef d2 (\s -> s - 0.1) >> postRedisplay 'g' -> updateIORef d3 (\s -> s + 0.1) >> postRedisplay 'h' -> updateIORef d3 (\s -> s - 0.1) >> postRedisplay 'j' -> updateIORef d4 (\s -> s + 0.1) >> postRedisplay 'k' -> updateIORef d4 (\s -> s - 0.1) >> postRedisplay 'z' -> updateIORef sh (\s -> s + 1.0) >> postRedisplay 'x' -> updateIORef sh (\s -> s - 1.0) >> postRedisplay '1' -> updateIORef a1 (\s -> s + 0.1) >> postRedisplay '2' -> updateIORef a1 (\s -> s - 0.1) >> postRedisplay '3' -> updateIORef a2 (\s -> s + 0.1) >> postRedisplay '4' -> updateIORef a2 (\s -> s - 0.1) >> postRedisplay '5' -> updateIORef a3 (\s -> s + 0.1) >> postRedisplay '6' -> updateIORef a3 (\s -> s - 0.1) >> postRedisplay '7' -> updateIORef a4 (\s -> s + 0.1) >> postRedisplay '8' -> updateIORef a4 (\s -> s - 0.1) >> postRedisplay '\27' -> shutdownHaskellAndExit 1 _ -> return () main :: IO () main = do angle <- newIORef 0.0 s1 <- newIORef 0.0 s2 <- newIORef 0.0 s3 <- newIORef 0.0 s4 <- newIORef 1.0 s5 <- newIORef 0.0 s6 <- newIORef 0.0 s7 <- newIORef 0.0 s8 <- newIORef 1.0 s9 <- newIORef 0.0 e1 <- newIORef 0.0 e2 <- newIORef 0.0 e3 <- newIORef 0.0 e4 <- newIORef 1.0 s10 <- newIORef 0.0 s11 <- newIORef 0.0 s12 <- newIORef 1.0 sh <- newIORef 0.0 (progName, _args) <- GLUT.init Nothing createWindow progName (return ()) [ GLUT.Double, GLUT.Rgb, GLUT.Depth ] (Just (WindowPosition 100 100)) (Just (WindowSize 500 500)) myInit reshapeFunc (Just reshape) keyboardFunc (Just (keyboard (s1, s2, s3, s4) (s5, s6, s7, s8) (s9, s10, s11, s12) sh)) specialFunc (Just (special (e1, e2, e3, e4))) idleFunc (Just (idle angle (s1, s2, s3, s4) (s5, s6, s7, s8) (s9, s10, s11, s12) (e1, e2, e3, e4) sh)) mainLoop