{-
   Mipmap.hs (adapted from mipmap.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 demonstrates using mipmaps for texture maps.
   To overtly show the effect of mipmaps, each mipmap reduction
   level has a solidly colored, contrasting texture image.
  Thus, the quadrilateral which is drawn is drawn with several
   different colors.
-}

import Control.Monad ( liftM )
import System.Exit   ( exitWith, ExitCode(ExitSuccess) )

import GL
import GLU
import Graphics.UI.GLUT

makeImages :: [Color4 GLubyte] -> IO ()
makeImages colors = sequence_ $
   zipWith3 (\lvl dim col -> do
               withArray (replicate (fromIntegral (dim*dim)) col) $
                  texImage2D Texture2d lvl GL.Rgba' dim dim 0 .
                  PixelDescriptor GL.Rgba UnsignedByte . castPtr)
            [ 0 .. ]
            (reverse . take (length colors) . iterate (*2) $ 1)
            colors

myInit :: IO TextureName
myInit = do
   enable DepthTest
   shadeModel GL.Flat

   translate (Vector3 0.0 0.0 (-3.6 :: GLfloat))
   pixelStore Unpack (Alignment 1)

   texName <- liftM head (genTextures 1)
   bindTexture Texture2d texName
   mapM_ (texParameter Texture2d) [
      TextureWrap S Repeat,
      TextureWrap T Repeat,
      TextureFilters NearestMipmapNearest Nearest ]
   makeImages [ Color4 255 255   0 255,
                Color4 255   0 255 255,
                Color4 255   0   0 255,
                Color4   0 255   0 255,
                Color4   0   0 255 255,
                Color4 255 255 255 255 ]

   texEnv (TextureEnvMode Decal)
   enable Texture2d'
   return texName

display :: TextureName -> DisplayCallback
display texName = do
   clear [ ColorBufferBit, DepthBufferBit ]
   bindTexture Texture2d texName
   beginEnd Quads $ do
      texCoord (TexCoord2 0 (0 :: GLfloat)); vertex (Vertex3 ( -2) (-1)     (0 :: GLfloat))
      texCoord (TexCoord2 0 (8 :: GLfloat)); vertex (Vertex3  (-2)   1      (0 :: GLfloat))
      texCoord (TexCoord2 8 (8 :: GLfloat)); vertex (Vertex3 2000    1  (-6000 :: GLfloat))
      texCoord (TexCoord2 8 (0 :: GLfloat)); vertex (Vertex3 2000  (-1) (-6000 :: GLfloat))
   flush

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   perspective 60.0 (fromIntegral w / fromIntegral h) 1.0 30000.0
   matrixMode Modelview
   loadIdentity

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 50 50)
   createWindow progName
   texName <- myInit
   setDisplayCallback (display texName)
   setReshapeCallback (Just reshape)
   setKeyboardMouseCallback (Just keyboard)
   mainLoop
