{-
   TexGen.hs (adapted from texgen.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 <Sven.Panne@informatik.uni-muenchen.de>

   This program draws a texture mapped teapot with 
   automatically generated texture coordinates.  The
   texture is rendered as stripes on the teapot.
   Initially, the object is drawn with texture coordinates
   based upon the object coordinates of the vertex
   and distance from the plane x = 0.  Pressing the 'e'
   key changes the coordinate generation to eye coordinates
   of the vertex.  Pressing the 'o' key switches it back
   to the object coordinates.  Pressing the 's' key 
   changes the plane to a slanted one (x + y + z = 0).
   Pressing the 'x' key switches it back to x = 0.
-}

import Control.Monad ( liftM )
import Data.Char     ( toLower )
import Data.IORef    ( IORef, newIORef, readIORef, writeIORef )
import System.Exit   ( exitWith, ExitCode(ExitSuccess) )

import GL
import Graphics.UI.GLUT

stripeImageWidth :: GLsizei
stripeImageWidth = 32

makeStripeImage :: (GLsizei -> PixelDescriptor -> IO ()) -> IO ()
makeStripeImage act =
   withArray [ Color4 (if j <= 4 then 255 else 0) (if j > 4 then 255 else 0) 0 (255 :: GLubyte)
             | j <- [ 0 .. stripeImageWidth - 1 ] ] $
      act stripeImageWidth . PixelDescriptor GL.Rgba UnsignedByte . castPtr

xequalzero, slanted :: Plane GLdouble
xequalzero = Plane 1 0 0 0
slanted    = Plane 1 1 1 0

myInit :: IO (TextureName, IORef (Plane GLdouble -> TexGenFunc), IORef (Plane GLdouble))
myInit = do
   clearColor (Color4 0.0 0.0 0.0 0.0)
   enable DepthTest
   shadeModel GL.Smooth

   pixelStore Unpack (Alignment 1)

   texName <- liftM head (genTextures 1)
   bindTexture Texture1d texName
   mapM_ (texParameter Texture1d) [
      TextureWrap S Repeat,
      TextureFilters Linear Linear ]
   makeStripeImage (\w pd -> texImage1D Texture1d 0 GL.Rgba' w 0 pd)

   texEnv (TextureEnvMode Modulate)
   genMode <- newIORef ObjectLinear
   currentPlane <- newIORef xequalzero
   texGen S (ObjectLinear xequalzero)

   enable TextureGenS
   enable Texture1d'
   enable CullFace
   enable Lighting
   enable (Light 0)
   enable AutoNormal
   enable Normalize
   frontFace GL.Cw
   cullFace Back
   material Front (Shininess 64.0)
   return (texName, genMode, currentPlane)

display :: TextureName -> DisplayCallback
display texName = do
   clear [ ColorBufferBit, DepthBufferBit ]

   pushMatrix
   rotate (45::GLfloat) (Vector3 0 0 1)
   bindTexture Texture1d texName
   renderObject Solid (Teapot 2.0)
   popMatrix
   flush

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   let wf = fromIntegral w
       hf = fromIntegral h
   if (w <= h)
      then ortho (-3.5) 3.5 (-3.5*hf/wf) (3.5*hf/wf) (-3.5) 3.5
      else ortho (-3.5*wf/hf) (3.5*wf/hf) (-3.5) 3.5 (-3.5) 3.5
   matrixMode Modelview
   loadIdentity

keyboard :: IORef (Plane GLdouble -> TexGenFunc) -> IORef (Plane GLdouble) -> KeyboardMouseCallback
keyboard genMode currentPlane (Char c) Down _ _ = case toLower c of
   'e'   -> do writeIORef genMode EyeLinear
               p <- readIORef currentPlane
               texGen S (EyeLinear p)
               postRedisplay
   'o'   -> do writeIORef genMode ObjectLinear
               p <- readIORef currentPlane
               texGen S (ObjectLinear p)
               postRedisplay
   's'   -> do g <- readIORef genMode
               writeIORef currentPlane slanted
               texGen S (g slanted)
               postRedisplay
   'x'   -> do g <- readIORef genMode
               writeIORef currentPlane xequalzero
               texGen S (g xequalzero)
               postRedisplay
   '\27' -> exitWith ExitSuccess
   _     -> return ()
keyboard _ _ _ _ _ _ = return ()

main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB, Graphics.UI.GLUT.Depth ]
   setInitialWindowSize (WindowSize 256 256)
   setInitialWindowPosition (WindowPosition 100 100)
   createWindow progName
   (texName, genMode, currentPlane) <- myInit
   setDisplayCallback (display texName)
   setReshapeCallback (Just reshape)
   setKeyboardMouseCallback (Just (keyboard genMode currentPlane))
   mainLoop
