{-
   TextureSurf.hs (adapted from texturesurf.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 uses evaluators to generate a curved
   surface and automatically generated texture coordinates.
-}

import System.Exit ( exitWith, ExitCode(ExitSuccess) )

import GL
import Graphics.UI.GLUT

ctrlPoints :: [[Vertex3 GLfloat]]
ctrlPoints = [
   [ Vertex3 (-1.5) (-1.5)   4.0,  Vertex3 (-0.5) (-1.5)  2.0,
     Vertex3 0.5    (-1.5) (-1.0), Vertex3   1.5  (-1.5)  2.0 ],
   [ Vertex3 (-1.5) (-0.5)   1.0,  Vertex3 (-0.5) (-0.5)  3.0,
     Vertex3 0.5    (-0.5)   0.0,  Vertex3   1.5  (-0.5)(-1.0) ],
   [ Vertex3 (-1.5)   0.5    4.0,  Vertex3 (-0.5)   0.5   0.0,
     Vertex3 0.5      0.5    3.0,  Vertex3   1.5    0.5   4.0 ],
   [ Vertex3 (-1.5)   1.5  (-2.0), Vertex3 (-0.5)   1.5 (-2.0),
     Vertex3 0.5      1.5    0.0,  Vertex3   1.5    1.5 (-1.0) ]]

texPts :: [[TexCoord2 GLfloat]]
texPts = [
   [ TexCoord2 0.0 0.0, TexCoord2 0.0 1.0 ],
   [ TexCoord2 1.0 0.0, TexCoord2 1.0 1.0 ]]

display :: DisplayCallback
display = do
   clear [ColorBufferBit, DepthBufferBit]
   color (Color3 1.0 1.0 1.0 :: Color3 GLfloat)
   evalMesh2 Fill 0 20 0 20
   flush

imageWidth :: Int
imageWidth = 64

imageHeight :: Int
imageHeight = 64

makeImage :: (PixelDescriptor -> IO ()) -> IO ()
makeImage act =
   withArray [ round (127.0 * (1.0 + c::Double)) :: GLubyte
             | i <- [0..imageWidth-1],
               let ti = 2.0 * pi * fromIntegral i / fromIntegral imageWidth,
               j <- [0..imageHeight-1],
               let tj = 2.0 * pi * fromIntegral j / fromIntegral imageHeight,
               c <- [sin ti, cos (2*tj), cos (ti+tj)]] $
   act . PixelDescriptor GL.Rgb UnsignedByte . castPtr

myInit :: IO ()
myInit = do
   withArray (concat ctrlPoints) $
      map2 Map2Vertex3 (0 :: GLfloat) 1 3 4 0 1 12 4 . castPtr
   withArray (concat texPts) $
      map2 Map2TextureCoord2 (0 :: GLfloat) 1 2 2 0 1 4 2 . castPtr
   enable Map2TextureCoord2
   enable Map2Vertex3
   mapGrid2 20 (0.0 :: GLfloat) 1.0 20 0.0 1.0
   texEnv (TextureEnvMode Decal)
   mapM_ (texParameter Texture2d) [ TextureWrap S Repeat,
                                    TextureWrap T Repeat,
                                    TextureFilters Nearest Nearest ]
   makeImage $ texImage2D Texture2d 0 GL.Rgb'
                          (fromIntegral imageWidth) (fromIntegral imageHeight) 0
   enable Texture2d'
   enable DepthTest
   shadeModel Flat

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 (-4.0) 4.0 (-4.0*hf/wf) (4.0*hf/wf) (-4.0) 4.0
      else ortho (-4.0*wf/hf) (4.0*wf/hf) (-4.0) 4.0 (-4.0) 4.0
   matrixMode Modelview
   loadIdentity
   rotate (85 :: GLfloat) (Vector3 1 1 1)

keyboard :: KeyboardMouseCallback
keyboard (Char '\27') Down _ _ = exitWith ExitSuccess
keyboard _            _    _ _ = return ()

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