{-
   PickDepth.hs (adapted from pickdepth.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>

   Picking is demonstrated in this program.  In 
   rendering mode, three overlapping rectangles are 
   drawn.  When the left mouse button is pressed, 
   selection mode is entered with the picking matrix.  
   Rectangles which are drawn under the cursor position
   are "picked."  Pay special attention to the depth 
   value range, which is returned.
-}

import Control.Monad ( when )
import System.Exit   ( exitWith, ExitCode(ExitSuccess) )

import GL
import GLU
import Graphics.UI.GLUT

myInit :: IO ()
myInit = do
   clearColor (Color4 0.0 0.0 0.0 0.0)
   enable DepthTest
   shadeModel GL.Flat
   depthRange 0.0 1.0   -- The default z mapping

-- The three rectangles are drawn.  In selection mode, 
-- each rectangle is given the same name.  Note that 
-- each rectangle is drawn with a different z value.
drawRects :: RenderMode -> IO ()
drawRects mode = do
   let color3  = color :: Color3 GLfloat -> IO ()
       vertex3 = vertex :: Vertex3 GLint -> IO ()
   when (mode == Select) $ loadName (SelectionName 1)
   beginEnd Quads $ do
      color3 (Color3 1.0 1.0 0.0)
      vertex3 (Vertex3 2 0 0)
      vertex3 (Vertex3 2 6 0)
      vertex3 (Vertex3 6 6 0)
      vertex3 (Vertex3 6 0 0)
   when (mode == Select) $ loadName (SelectionName 2)
   beginEnd Quads $ do
      color3 (Color3 0.0 1.0 1.0)
      vertex3 (Vertex3 3 2 (-1))
      vertex3 (Vertex3 3 8 (-1))
      vertex3 (Vertex3 8 8 (-1))
      vertex3 (Vertex3 8 2 (-1))
   when (mode == Select) $ loadName (SelectionName 3)
   beginEnd Quads $ do
      color3 (Color3 1.0 0.0 1.0)
      vertex3 (Vertex3 0 2 (-2))
      vertex3 (Vertex3 0 7 (-2))
      vertex3 (Vertex3 5 7 (-2))
      vertex3 (Vertex3 5 2 (-2))

-- 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

-- pickRects() sets up selection mode, name stack,
-- and projection matrix for picking.  Then the objects
-- are drawn.
pickRects :: KeyboardMouseCallback
pickRects (MouseButton LeftButton) Down _ (WindowPosition x y) = do
   (winPosition@(_::GLint,_::GLint), winSize@(_::GLsizei, height::GLsizei)) <- get VarViewport

   -- NOTE: This could be moved to myInit for efficiency
   selectBuf <- makeSelectionBuffer 512
   selectBuffer selectBuf
   renderMode Select

   initNames
   pushName (SelectionName 0)

   matrixMode Projection
   pushMatrix
   loadIdentity
   -- create 5x5 pixel picking region near cursor location
   pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5.0, 5.0) winPosition winSize
   ortho 0.0 8.0 0.0 8.0 (-0.5) 2.5
   drawRects Select
   popMatrix
   flush

   hits <- renderMode Render
   processHits hits selectBuf
   freeSelectionBuffer selectBuf
pickRects (Char '\27') Down _ _ = exitWith ExitSuccess
pickRects _            _    _ _ = return ()

display :: DisplayCallback
display = do
   clear [ ColorBufferBit, DepthBufferBit ]
   drawRects Render
   flush

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   ortho 0.0 8.0 0.0 8.0 (-0.5) 2.5
   matrixMode Modelview
   loadIdentity

-- 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
   setReshapeCallback (Just reshape)
   setDisplayCallback display
   setKeyboardMouseCallback (Just pickRects)
   mainLoop
