{-
   AAPoly.hs  (adapted from aapoly.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@BetaResearch.de>

   This program draws filled polygons with antialiased
   edges.  The special GL_SRC_ALPHA_SATURATE blending 
   function is used.
   Pressing the 't' key turns the antialiasing on and off.
-}

import Data.Char             ( toLower )
import Data.IORef            ( IORef, newIORef, readIORef, modifyIORef )
import Data.List             ( genericLength )
import Foreign.Marshal.Array ( withArray )
import System.Exit           ( exitWith, ExitCode(ExitSuccess) )

import GL
import GLU
import Graphics.UI.GLUT

myInit :: IO ()
myInit = do
   cullFace Back
   enable CullFace
   blendFunc SrcAlphaSaturate One
   clearColor (Color4 0 0 0 0)

drawCube :: Vertex3 GLfloat -> Vertex3 GLfloat -> IO ()
drawCube (Vertex3 x0 y0 z0) (Vertex3 x1 y1 z1) = do
   enableClientState VertexArray
   enableClientState ColorArray
   withArray [
      Vertex3 x0 y0 z0, Vertex3 x1 y0 z0,
      Vertex3 x1 y1 z0, Vertex3 x0 y1 z0,
      Vertex3 x0 y0 z1, Vertex3 x1 y0 z1,
      Vertex3 x1 y1 z1, Vertex3 x0 y1 z1 ] $ \vertexBuffer -> do
   vertexPointer 3 Float 0 vertexBuffer
   withArray  [
      Color4 0 0 0 1, Color4 1 0 0 1,
      Color4 0 1 0 1, Color4 1 1 0 1,
      Color4 0 0 1 1, Color4 1 0 1 1,
      Color4 0 1 1 1, Color4 1 1 1 (1 :: GLfloat)] $ \colorBuffer -> do
   colorPointer 4 Float 0 colorBuffer
   -- indices of front, top, left, bottom, right, back faces
   let indices = [ 4, 5, 6, 7,
                   2, 3, 7, 6,
                   0, 4, 7, 3,
                   0, 1, 5, 4,
                   1, 5, 6, 2,
                   0, 3, 2, (1 :: GLubyte)]
   withArray indices $ drawElements Quads (genericLength indices) UnsignedByte . castPtr
   disableClientState VertexArray
   disableClientState ColorArray

-- Note: Polygons must be drawn from front to back
-- for proper blending.
display :: IORef Bool -> DisplayCallback
display polySmooth = do
   smooth <- readIORef polySmooth
   if smooth
      then do clear [ ColorBufferBit ]
              enable Blend'
              enable PolygonSmooth
              disable DepthTest
      else do clear [ ColorBufferBit, DepthBufferBit ]
              disable Blend'
              disable PolygonSmooth
              enable DepthTest
   pushMatrix
   translate (Vector3 0 0 (-8 :: GLfloat))
   rotate (30 :: GLfloat) (Vector3 1 0 0)
   rotate (60 :: GLfloat) (Vector3 0 1 0)
   drawCube (Vertex3 (-0.5) (-0.5) (-0.5)) (Vertex3 0.5 0.5 0.5)
   popMatrix

   flush

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   perspective 30 (fromIntegral w / fromIntegral h) 1 20
   matrixMode Modelview
   loadIdentity

keyboard :: IORef Bool -> KeyboardMouseCallback
keyboard polySmooth (Char c) Down _ _ = case toLower c of
   't'   -> do modifyIORef polySmooth not; postRedisplay
   '\27' -> exitWith ExitSuccess
   _     -> return ()
keyboard _ _ _ _ _ = return ()

--  Main Loop
main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB, Graphics.UI.GLUT.Alpha, Graphics.UI.GLUT.Depth ]
   setInitialWindowSize (WindowSize 200 200)
   createWindow progName
   myInit
   setReshapeCallback (Just reshape)
   polySmooth <- newIORef True
   setKeyboardMouseCallback (Just (keyboard polySmooth))
   setDisplayCallback (display polySmooth) 
   mainLoop
