{-
   Select.hs (adapted from select.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 an illustration of the selection mode and
   name stack, which detects whether objects which collide
   with a viewing volume.  First, four triangles and a
   rectangular box representing a viewing volume are drawn
   (drawScene routine).  The green triangle and yellow
   triangles appear to lie within the viewing volume, but
   the red triangle appears to lie outside it.  Then the
   selection mode is entered (selectObjects routine).
   Drawing to the screen ceases.  To see if any collisions
   occur, the four triangles are called.  In this example,
   the green triangle causes one hit with the name 1, and
   the yellow triangles cause one hit with the name 3.
-}

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

import GL
import GLU
import Graphics.UI.GLUT

-- draw a triangle with vertices at (x1, y1), (x2, y2)
-- and (x3, y3) at z units away from the origin.
drawTriangle :: Vertex2 GLfloat -> Vertex2 GLfloat -> Vertex2 GLfloat -> GLfloat -> IO ()
drawTriangle (Vertex2 x1 y1) (Vertex2 x2 y2) (Vertex2 x3 y3) z = do
   beginEnd Triangles $ mapM_ vertex [
      Vertex3 x1 y1 z,
      Vertex3 x2 y2 z,
      Vertex3 x3 y3 z]

-- draw a rectangular box with these outer x, y, and z values
drawViewVolume :: Vertex3 GLfloat -> Vertex3 GLfloat -> IO ()
drawViewVolume (Vertex3 x1 y1 z1) (Vertex3 x2 y2 z2) = do
   color (Color3 1.0 1.0 1.0 :: Color3 GLfloat)
   beginEnd LineLoop $ mapM_ vertex [
      Vertex3 x1 y1 (-z1),
      Vertex3 x2 y1 (-z1),
      Vertex3 x2 y2 (-z1),
      Vertex3 x1 y2 (-z1)]

   beginEnd LineLoop $ mapM_ vertex [
      Vertex3 x1 y1 (-z2),
      Vertex3 x2 y1 (-z2),
      Vertex3 x2 y2 (-z2),
      Vertex3 x1 y2 (-z2)]

   beginEnd Lines $ mapM_ vertex [   -- 4 lines
      Vertex3 x1 y1 (-z1),
      Vertex3 x1 y1 (-z2),
      Vertex3 x1 y2 (-z1),
      Vertex3 x1 y2 (-z2),
      Vertex3 x2 y1 (-z1),
      Vertex3 x2 y1 (-z2),
      Vertex3 x2 y2 (-z1),
      Vertex3 x2 y2 (-z2)]

-- drawScene draws 4 triangles and a wire frame
-- which represents the viewing volume.
drawScene :: IO ()
drawScene = do
   matrixMode Projection
   loadIdentity
   perspective 40.0 (4.0/3.0) 1.0 100.0

   matrixMode Modelview
   loadIdentity
   lookAt (7.5, 7.5, 12.5) (2.5, 2.5, -5.0) (0.0, 1.0, 0.0)
   color (Color3 0.0 1.0 0.0 :: Color3 GLfloat)   -- green triangle
   drawTriangle (Vertex2 2.0 2.0) (Vertex2 3.0 2.0) (Vertex2 2.5 3.0) (-5.0)
   color (Color3 1.0 0.0 0.0 :: Color3 GLfloat)   -- red triangle
   drawTriangle (Vertex2 2.0 7.0) (Vertex2 3.0 7.0) (Vertex2 2.5 8.0) (-5.0)
   color (Color3 1.0 1.0 0.0 :: Color3 GLfloat)   -- yellow triangles
   drawTriangle (Vertex2 2.0 2.0) (Vertex2 3.0 2.0) (Vertex2 2.5 3.0) (-1.0)
   drawTriangle (Vertex2 2.0 2.0) (Vertex2 3.0 2.0) (Vertex2 2.5 3.0) (-9.0)
   drawViewVolume (Vertex3 0.0 0.0 0.0) (Vertex3 5.0 5.0 10.0)

-- processHits prints out the contents of the selection array
processHits :: GLint -> SelectionBuffer -> IO ()
processHits hits buffer = do
   putStrLn ("hits = " ++ show hits)
   Just theHits <- getSelectionHits hits buffer
   mapM_ (\(SelectionHit z1 z2 names) -> do
      putStrLn (" number of names for hit = " ++ show (length names))
      putStr   ("  z1 is " ++ show z1)
      putStrLn ("; z2 is " ++ show z2)
      putStr   "   the name is"
      sequence_ [ putStr (" " ++ show n) | SelectionName n <- names ]
      putChar '\n')
      theHits

-- selectObjects "draws" the triangles in selection mode,
-- assigning names for the triangles.  Note that the third
-- and fourth triangles share one name, so that if either
-- or both triangles intersects the viewing/clipping volume,
-- only one hit will be registered.
selectObjects :: IO ()
selectObjects = do
   -- NOTE: This could be moved to myInit for efficiency
   selectBuf <- makeSelectionBuffer 512
   selectBuffer selectBuf
   renderMode Select

   initNames
   pushName (SelectionName 0)

   pushMatrix
   matrixMode Projection
   loadIdentity
   ortho 0.0 5.0 0.0 5.0 0.0 10.0
   matrixMode Modelview
   loadIdentity
   loadName (SelectionName 1)
   drawTriangle (Vertex2 2.0 2.0) (Vertex2 3.0 2.0) (Vertex2 2.5 3.0) (-5.0)
   loadName (SelectionName 2)
   drawTriangle (Vertex2 2.0 7.0) (Vertex2 3.0 7.0) (Vertex2 2.5 8.0) (-5.0)
   loadName (SelectionName 3)
   drawTriangle (Vertex2 2.0 2.0) (Vertex2 3.0 2.0) (Vertex2 2.5 3.0) (-1.0)
   drawTriangle (Vertex2 2.0 2.0) (Vertex2 3.0 2.0) (Vertex2 2.5 3.0) (-9.0)
   popMatrix
   flush

   hits <- renderMode Render
   processHits hits selectBuf
   freeSelectionBuffer selectBuf

myInit :: IO ()
myInit = do
   enable DepthTest
   shadeModel GL.Flat

display :: DisplayCallback
display = do
   clearColor (Color4 0.0 0.0 0.0 0.0)
   clear [ ColorBufferBit, DepthBufferBit ]
   drawScene
   selectObjects
   flush

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

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