{-
   Double.hs (adapted from double.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 is a simple double buffered program.
   Pressing the left mouse button rotates the rectangle.
   Pressing the middle mouse button stops the rotation.
-}

import Data.IORef ( IORef, newIORef, readIORef, writeIORef )

import GL
import Graphics.UI.GLUT

display :: IORef GLfloat -> DisplayCallback
display spin = do
   clear [ColorBufferBit]
   pushMatrix
   s <- readIORef spin
   rotate s (Vector3 0 0 1)
   color (Color3 1.0 1.0 1.0 :: Color3 GLfloat)
   rect (Vertex2 (-25 :: GLfloat) (-25)) (Vertex2 25 25)
   popMatrix
   swapBuffers

spinDisplay :: IORef GLfloat -> IdleCallback
spinDisplay spin = do
   s1 <- readIORef spin
   let s2 = s1 + 2.0
   writeIORef spin (if s2 > 360.0 then s2 - 360.0 else s2)
   postRedisplay

myInit :: IO ()
myInit = do
   clearColor (Color4 0.0 0.0 0.0 0.0)
   shadeModel Smooth

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   ortho (-50.0) 50.0 (-50.0) 50.0 (-1.0) 1.0
   matrixMode Modelview
   loadIdentity

mouse :: IORef GLfloat -> KeyboardMouseCallback
mouse spin (MouseButton LeftButton) Down _ _ = setIdleCallback (Just (spinDisplay spin))
mouse _    (MouseButton _         ) Down _ _ = setIdleCallback Nothing
mouse _    _                        _    _ _ = return ()

--  Request double buffer display mode.
--  Register mouse input callback functions

main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   spin <- newIORef 0.0
   setInitialDisplayMode [ Graphics.UI.GLUT.Double, RGB ]
   setInitialWindowSize (WindowSize 250 250)
   setInitialWindowPosition (WindowPosition 100 100)
   createWindow progName
   myInit
   setDisplayCallback (display spin)
   setReshapeCallback (Just reshape)
   setKeyboardMouseCallback (Just (mouse spin))
   mainLoop
