{-
   TexSub.hs (adapted from texsub.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 texture maps a checkerboard image onto
   two rectangles.  This program clamps the texture, if
   the texture coordinates fall outside 0.0 and 1.0.
   If the s key is pressed, a texture subimage is used to
   alter the original texture.  If the r key is pressed, 
   the original texture is restored.
-}

import Data.Bits     ( (.&.) )
import Data.Char     ( toLower )
import Control.Monad ( liftM )
import System.Exit   ( exitWith, ExitCode(ExitSuccess) )

import GL
import GLU
import Graphics.UI.GLUT

checkImageWidth, checkImageHeight, subImageWidth, subImageHeight :: GLsizei
checkImageWidth  = 64
checkImageHeight = 64
subImageWidth    = 16
subImageHeight   = 16

makeCheckImage :: Color4 GLubyte -> GLsizei -> GLsizei -> GLsizei
               -> (PixelDescriptor -> GLsizei -> GLsizei -> IO ()) -> IO ()
makeCheckImage col mask width height act =
   withArray [ if (i .&. mask) == (j .&. mask) then Color4 0 0 0 255 else col
             | i <- [ 0 .. height - 1 ],
               j <- [ 0 .. width  - 1 ] ] $ \a ->
   act (PixelDescriptor GL.Rgba UnsignedByte (castPtr a)) width height

myInit :: IO TextureName
myInit = do
   clearColor (Color4 0.0 0.0 0.0 0.0)
   shadeModel GL.Flat
   enable DepthTest

   pixelStore Unpack (Alignment 1)

   texName <- liftM head (genTextures 2)
   bindTexture Texture2d texName

   mapM_ (texParameter Texture2d) [
      TextureWrap S Repeat,
      TextureWrap T Repeat,
      TextureFilters Nearest Nearest ]
   makeCheckImage (Color4 255 255 255 255) 0x08 checkImageWidth checkImageHeight
                  (\pd w h -> texImage2D Texture2d 0 GL.Rgba' w h 0 pd)

   return texName

display :: TextureName -> DisplayCallback
display texName = do
   clear [ ColorBufferBit, DepthBufferBit ]
   enable Texture2d'
   texEnv (TextureEnvMode Decal)
   bindTexture Texture2d texName
   let texCoord2 :: GLfloat -> GLfloat -> IO ()
       texCoord2 x y = texCoord (TexCoord2 x y)
       vertex3 :: GLfloat -> GLfloat -> GLfloat -> IO ()
       vertex3 x y z = vertex (Vertex3 x y z)
   beginEnd Quads $ do
      texCoord2 0.0 0.0;  vertex3 (-2.0)    (-1.0)   0.0
      texCoord2 0.0 1.0;  vertex3 (-2.0)      1.0    0.0
      texCoord2 1.0 1.0;  vertex3   0.0       1.0    0.0
      texCoord2 1.0 0.0;  vertex3   0.0     (-1.0)   0.0

      texCoord2 0.0 0.0;  vertex3   1.0     (-1.0)   0.0
      texCoord2 0.0 1.0;  vertex3   1.0       1.0    0.0
      texCoord2 1.0 1.0;  vertex3   2.41421   1.0  (-1.41421)
      texCoord2 1.0 0.0;  vertex3   2.41421 (-1.0) (-1.41421)
   flush
   disable Texture2d'

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 30.0
   matrixMode Modelview
   loadIdentity
   translate (Vector3 0 0 (-3.6 :: GLfloat))

keyboard :: TextureName -> KeyboardMouseCallback
keyboard texName (Char c) Down _ _ = case toLower c of
   's'   -> do bindTexture Texture2d texName
               makeCheckImage (Color4 255 0 0 255) 0x04 subImageWidth subImageHeight
                              (\pd w h -> texSubImage2D Texture2d 0 12 44 w h pd)
               postRedisplay
   'r'   -> do bindTexture Texture2d texName
               makeCheckImage (Color4 255 255 255 255) 0x08 checkImageWidth checkImageHeight
                              (\pd w h -> texImage2D Texture2d 0 GL.Rgba' w h 0 pd)
               postRedisplay
   '\27' -> exitWith ExitSuccess
   _     -> return ()
keyboard _ _ _ _ _ = return ()

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