{-
   AccPersp.hs  (adapted from accpersp.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>

   Use the accumulation buffer to do full-scene antialiasing on
   a scene with with perspective projection, using the special
   functions accFrustum and accPerspective.
-}

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

import GL
import Graphics.UI.GLUT

import Jitter

-- accFrustum()
-- The first 6 arguments are identical to the frustum call.
--  
-- pixDx and pixDy are anti-alias jitter in pixels. 
-- Set both equal to 0.0 for no anti-alias jitter.
-- eyeDx and eyeDy are depth-of field jitter in pixels. 
-- Set both equal to 0.0 for no depth of field effects.
--
-- focus is distance from eye to plane in focus. 
-- focus must be greater than, but not equal to 0.0.
--
-- Note that accFrustum calls translate.  You will 
-- probably want to insure that your ModelView matrix has been 
-- initialized to identity before calling accFrustum.
accFrustum :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble
           -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO ()
accFrustum left right bottom top zNear zFar pixDx pixDy eyeDx eyeDy focus = do
   ((_::GLint,_::GLint), (width::GLsizei, height::GLsizei)) <- get VarViewport
	
   let xWSize = right - left
       yWSize = top - bottom

       dx     = -(pixDx*xWSize / fromIntegral width  + eyeDx*zNear / focus)
       dy     = -(pixDy*yWSize / fromIntegral height + eyeDy*zNear / focus)

   matrixMode Projection
   loadIdentity
   frustum (left + dx) (right + dx) (bottom + dy) (top + dy) zNear zFar
   matrixMode Modelview
   loadIdentity
   translate (Vector3 (-eyeDx) (-eyeDy) 0)

-- accPerspective()
-- 
-- The first 4 arguments are identical to the gluPerspective() call.
-- pixDx and pixDy are anti-alias jitter in pixels. 
-- Set both equal to 0.0 for no anti-alias jitter.
-- eyedx and eyedy are depth-of field jitter in pixels. 
-- Set both equal to 0.0 for no depth of field effects.
--
-- focus is distance from eye to plane in focus. 
-- focus must be greater than, but not equal to 0.0.
--
-- Note that accPerspective calls accFrustum.
accPerspective :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GLdouble
               -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> IO ()
accPerspective fovY aspect zNear zFar pixDx pixDy eyeDx eyeDy focus =
   let fov2   = ((fovY*pi) / 180) / 2

       top    = zNear / (cos fov2 / sin fov2)
       bottom = -top

       right  = top * aspect
       left   = -right

   in accFrustum left right bottom top zNear zFar
                 pixDx pixDy eyeDx eyeDy focus

-- Initialize lighting and other values.
myInit :: IO ()
myInit = do
   mapM_ (material Front) [ MaterialColor Ambient  (Color4 1.0 1.0 1.0 1.0),
                            MaterialColor Specular (Color4 1.0 1.0 1.0 1.0),
                            Shininess 50 ]
   light (Light 0) (Position (Vertex4 0.0 0.0 10.0 1.0))
   lightModel (LightModelAmbient (Color4 0.2 0.2 0.2 1.0))

   enable Lighting
   enable (Light 0)
   enable DepthTest
   shadeModel Flat

   clearColor (Color4 0.0 0.0 0.0 0.0)
   clearAccum (Color4 0.0 0.0 0.0 0.0)

displayObjects :: IO ()
displayObjects = do
   pushMatrix
   translate (Vector3 0 0 (-5) :: Vector3 GLfloat)
   rotate (30 :: GLfloat) (Vector3 1 0 0)

   pushMatrix
   translate (Vector3 (-0.80) 0.35 0 :: Vector3 GLfloat)
   rotate (100 :: GLfloat) (Vector3 1 0 0)
   material Front (MaterialColor Diffuse (Color4 0.7 0.7 0.0 1.0))
   renderObject Solid (Torus 0.275 0.85 16 16)
   popMatrix

   pushMatrix
   translate (Vector3 (-0.75) (-0.50) 0 :: Vector3 GLfloat)
   rotate (45 :: GLfloat) (Vector3 0 0 1)
   rotate (45 :: GLfloat) (Vector3 1 0 0)
   material Front (MaterialColor Diffuse (Color4 0.0 0.7 0.7 1.0))
   renderObject Solid (Cube 1.5)
   popMatrix

   pushMatrix
   translate (Vector3 0.75 0.60 0 :: Vector3 GLfloat)
   rotate (30 :: GLfloat) (Vector3 1 0 0)
   material Front (MaterialColor Diffuse (Color4 0.7 0.0 0.7 1.0))
   renderObject Solid (Sphere 1.0 16 16)
   popMatrix

   pushMatrix
   translate (Vector3 0.70 (-0.90) 0.25 :: Vector3 GLfloat)
   material Front (MaterialColor Diffuse (Color4 0.7 0.4 0.4 1.0))
   renderObject Solid Octahedron
   popMatrix

   popMatrix

display :: DisplayCallback
display = do
   ((_::GLint,_::GLint), (width::GLsizei, height::GLsizei)) <- get VarViewport

   clear [ AccumBufferBit ]
   let jitter = j8
       len    = fromIntegral (length jitter)
   sequence_ [ do
      clear [ ColorBufferBit, DepthBufferBit ]
      accPerspective 50 (fromIntegral width / fromIntegral height) 1 15
                     (realToFrac x) (realToFrac y) 0 0 1
      displayObjects
      accum GL.Accum (1.0/len)
            | JitterPoint x y <- jitter ]
   accum Return 1.0
   flush

reshape :: ReshapeCallback
reshape (WindowSize w h) = viewport (0, 0) (fromIntegral w, fromIntegral h)

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

-- Main Loop
-- Be certain you request an accumulation buffer.
main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB, Graphics.UI.GLUT.Accum, Graphics.UI.GLUT.Depth ]
   setInitialWindowSize (WindowSize 250 250)
   setInitialWindowPosition (WindowPosition 100 100)
   createWindow progName
   myInit
   setReshapeCallback (Just reshape)
   setDisplayCallback display
   setKeyboardMouseCallback (Just keyboard)
   mainLoop
