{-
   Torus.hs (adapted from torus.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 the creation of a display list.
-}

import Data.Char   ( toLower )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )

import GL
import GLU
import Graphics.UI.GLUT

-- Hey mom, look, it's C!  ;-)
for :: Int -> Int -> (Int -> IO ()) -> IO ()
for s e f = mapM_ f [ i | i <- [s, if s<=e then s+1 else s-1 .. e] ]

-- Draw a torus
torus :: Int -> Int -> IO ()
torus numC numT = do
   let twoPi = 2 * pi
       numCf = fromIntegral numC
       numTf = fromIntegral numT
   for 0 (numC-1) (\i ->
      do begin QuadStrip
         for 0 numT (\j ->
            for 1 0 (\k ->
            let s = fromIntegral ((i + k) `mod` numC) + 0.5
                t = fromIntegral (j `mod` numT)

                x = (1+0.1*cos(s*twoPi/numCf))*cos(t*twoPi/numTf)
                y = (1+0.1*cos(s*twoPi/numCf))*sin(t*twoPi/numTf)
                z =    0.1*sin(s*twoPi/numCf) :: GLfloat
            in vertex (Vertex3 x y z)))
         end)

-- Create display list with Torus and initialize state
myInit :: IO DisplayList
myInit = do
   [theTorus] <- genLists 1
   newEndList theTorus Compile $ torus 8 25

   shadeModel GL.Flat
   clearColor (Color4 0.0 0.0 0.0 0.0)
   return theTorus

-- Clear window and draw torus
display :: DisplayList -> IO ()
display theTorus = do
   clear [ColorBufferBit]
   color (Color3 1.0 1.0 1.0 :: Color3 GLfloat)
   callList theTorus
   flush

-- Handle window resize
reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   perspective 30 (fromIntegral w / fromIntegral h) 1 100
   matrixMode Modelview
   loadIdentity
   lookAt (0, 0, 10) (0, 0, 0) (0, 1, 0)

-- Rotate about x-axis when "x" typed; rotate about y-axis
-- when "y" typed; "i" returns torus to original view
keyboard :: KeyboardMouseCallback
keyboard (Char c) Down _ _ = case toLower c of
   'x'   -> do rotate (30 :: GLfloat) (Vector3 1 0 0)
               postRedisplay
   'y'   -> do rotate (30 :: GLfloat) (Vector3 0 1 0)
               postRedisplay
   'i'   -> do loadIdentity
               lookAt (0, 0, 10) (0, 0, 0) (0, 1, 0)
               postRedisplay
   '\27' -> exitWith ExitSuccess
   _     -> return ()
keyboard _ _ _ _ = return ()

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