-- Hey Emacs, this is -*- haskell -*- !
-- An ugly example demonstrating user interaction with GLUT.
-- Sven Panne 2000.   mailto:Sven.Panne@informatik.uni-muenchen.de

import Data.IORef(IORef, newIORef, readIORef, writeIORef)
import System.Exit(exitWith, ExitCode(ExitSuccess))
import GL
import Graphics.UI.GLUT

instance Show MouseButton where
   showsPrec _ LeftButton   = showString "left button"
   showsPrec _ MiddleButton = showString "middle button"
   showsPrec _ RightButton  = showString "right button"
   showsPrec _ WheelUp      = showString "wheel up"
   showsPrec _ WheelDown    = showString "wheel down"

instance Show KeyState where
   showsPrec _ Down = showString "down"
   showsPrec _ Up   = showString "up"

instance Show WindowPosition where
   showsPrec p (WindowPosition x y) =
      showParen (p >= 9)
                (showString "position " . shows x . showChar ' ' . shows y)

instance Show WindowSize where
   showsPrec p (WindowSize w h) =
      showParen (p >= 9)
                (showString "size " . shows w . showChar ' ' . shows h)

main :: IO ()
main = do
   (progName, args) <- getArgsAndInitialize
   putStrLn ("Program name: " ++ progName ++ ", arguments: " ++ show args)
   
   setInitialDisplayMode [ Single, RGBA ]

   setInitialWindowPosition (WindowPosition 100 100)
   setInitialWindowSize     (WindowSize     400 400)
   createWindow "Window 1"
   setCursor Help
   setDisplayCallback $ do
      clear [ColorBufferBit]
      putStrLn "displaying Window 1..."
   counter <- newIORef 0
   setKeyboardMouseCallback (Just (keyboardMouseCallback1 counter))
   setReshapeCallback (Just print)
   
   setInitialWindowPosition (WindowPosition 400 200)
   createWindow "Window 2"
   setCursor Crosshair
   setDisplayCallback $ do
      clear [ColorBufferBit]
      putStrLn "displaying Window 2..."
   menuUsage <- newIORef NotInUse
   setMenuStatusCallback (Just (menuTracker menuUsage))
   setKeyboardMouseCallback (Just (keyboardMouseCallback2 menuUsage))
   
   attachMenu MiddleButton (Menu [
      SubMenu "Colors" (Menu [
         MenuEntry "Red"     (putStrLn "Red"),
         MenuEntry "Green"   (putStrLn "Green"),
         MenuEntry "Blue"    (putStrLn "Blue"),
         MenuEntry "Cyan"    (putStrLn "Cyan"),
         MenuEntry "Magenta" (putStrLn "Magenta"),
         MenuEntry "Yellow"  (putStrLn "Yellow"),
         MenuEntry "White"   (putStrLn "White"),
         MenuEntry "Black"   (putStrLn "Black")]),
      SubMenu "Pixel Size" (Menu [
         MenuEntry "increase pixel size" (putStrLn "increasing"),
         MenuEntry "decrease pixel size" (putStrLn "decreasing")]),
      SubMenu "Fill" (Menu [
         MenuEntry "fill on"  (putStrLn "fill on"),
         MenuEntry "fill off" (putStrLn "fill off")])])
   
   attachMenu RightButton (Menu [
      MenuEntry "quit"  (exitWith ExitSuccess),
      MenuEntry "clear" (putStrLn "clear")])
   
   mainLoop

keyboardMouseCallback1 :: IORef Int -> KeyboardMouseCallback
keyboardMouseCallback1 counter (MouseButton mouseButton) state _ position = do
   n <- readIORef counter
   writeIORef counter (n+1)
   putStrLn ((shows n . showString ") " . shows mouseButton . showChar ' ' .
              shows state . showString " at " . shows position) "")
keyboardMouseCallback1 _       (Char '\27') Down _ _ = exitWith ExitSuccess
keyboardMouseCallback1 _       _            Down _ _ = putStrLn "Hit ESC to quit"
keyboardMouseCallback1 _       _            _    _ _ = return ()

keyboardMouseCallback2 :: IORef MenuUsage -> KeyboardMouseCallback
keyboardMouseCallback2 menuUsage (Char c) Down _ position = do
   putStr ((showString "User typed '" . showChar c .
            showString "' at " . shows position) ". ")
   mUsage <- readIORef menuUsage
   case mUsage of
      NotInUse -> do putStrLn "Registering new menu entry."
                     attachMenu LeftButton (Menu [ MenuEntry ("Last char") (print c) ])
      InUse    -> putStrLn "Menu active, ignoring key."
keyboardMouseCallback2 _ _ _ _ _ = return ()

menuTracker :: IORef MenuUsage -> MenuStatusCallback
menuTracker menuUsage mUsage _ = writeIORef menuUsage mUsage
