{-
   PickSquare.hs (adapted from picksquare.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 of multiple names and picking are demonstrated.  
   A 3x3 grid of squares is drawn.  When the left mouse 
   button is pressed, all squares under the cursor position 
   have their color changed.
-}

import Control.Monad ( when )
import Data.Array    ( Array, listArray, (!) )
import Data.IORef    ( IORef, newIORef, readIORef, modifyIORef )
import System.Exit   ( exitWith, ExitCode(ExitSuccess) )

import GL
import GLU
import Graphics.UI.GLUT

type Board = Array (GLint,GLint) (IORef Int)

myInit :: IO Board
myInit = do
   clearColor (Color4 0.0 0.0 0.0 0.0)
   refs <- sequence . replicate 9 . newIORef $ 0
   return $ listArray ((0,0),(2,2)) refs

-- The nine squares are drawn.  In selection mode, each 
-- square is given two names:  one for the row and the 
-- other for the column on the grid.  The color of each 
-- square is determined by its position on the grid, and 
-- the value in the board[][] array.
drawSquares :: Board -> RenderMode -> IO ()
drawSquares board mode =
   mapM_ (\i -> do
      when (mode == Select) $ loadName (SelectionName (fromIntegral i))
      mapM_ (\j -> do
         when (mode == Select) $ pushName (SelectionName (fromIntegral j))
         val <- readIORef (board ! (i,j))
         color (Color3 (fromIntegral i   / 3.0 :: GLfloat)
                       (fromIntegral j   / 3.0)
                       (fromIntegral val / 3.0))
         rect (Vertex2 i j) (Vertex2 (i+1) (j+1))
         when (mode == Select) popName)
         [ 0 .. 2 ])
      [ 0 .. 2 ]

-- processHits prints out the contents of the
-- selection array.
processHits :: Board -> GLint -> SelectionBuffer -> IO ()
processHits board hits buffer = do
   putStrLn ("hits = " ++ show hits)
   Just theHits <- getSelectionHits hits buffer
   mapM_ (\(SelectionHit z1 z2 names) -> do
      putStrLn (" number of names for this hit = " ++ show (length names))
      putStr   ("  z1 is " ++ show z1)
      putStrLn ("; z2 is " ++ show z2)
      putStr   "   names are"
      sequence_ [ putStr (" " ++ show n) | SelectionName n <- names ]
      putChar '\n'
      let [i, j] = [ fromIntegral n | SelectionName n <- names ]
      modifyIORef (board ! (i,j)) (\x -> (x + 1) `mod` 3))
      theHits

-- pickSquares sets up selection mode, name stack, 
-- and projection matrix for picking.  Then the 
-- objects are drawn.
pickSquares :: Board -> KeyboardMouseCallback
pickSquares board (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
   ortho2D 0.0 3.0 0.0 3.0
   drawSquares board Select

   matrixMode Projection
   popMatrix
   flush

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

display :: Board -> DisplayCallback
display board = do
   clear [ ColorBufferBit ]
   drawSquares board Render
   flush

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   ortho2D 0.0 3.0 0.0 3.0
   matrixMode Modelview
   loadIdentity

-- Main Loop
main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB ]
   setInitialWindowSize (WindowSize 100 100)
   setInitialWindowPosition (WindowPosition 100 100)
   createWindow progName
   board <- myInit
   setReshapeCallback (Just reshape)
   setDisplayCallback (display board)
   setKeyboardMouseCallback (Just (pickSquares board))
   mainLoop
