{-
   Feedback.hs (adapted from feedback.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 use of OpenGL feedback.  First,
   a lighting environment is set up and a few lines are drawn.
   Then feedback mode is entered, and the same lines are 
   drawn.  The results in the feedback buffer are printed.
-}

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

import GL
import Graphics.UI.GLUT

-- Initialize lighting.
myInit :: IO ()
myInit = do
   enable Lighting
   enable (Light 0)

-- Draw a few lines and two points, one of which will 
-- be clipped.  If in feedback mode, a passthrough token 
-- is issued between the each primitive.
drawGeometry :: RenderMode -> IO ()
drawGeometry mode = do
   beginEnd LineStrip $ do
      normal (Normal3  0.0  0.0 1.0 :: Normal3 GLfloat)
      vertex (Vertex3 30.0 30.0 0.0 :: Vertex3 GLfloat)
      vertex (Vertex3 50.0 60.0 0.0 :: Vertex3 GLfloat)
      vertex (Vertex3 70.0 40.0 0.0 :: Vertex3 GLfloat)
   when (mode == Feedback) $ passThrough (PassThroughValue 1.0)
   beginEnd Points $   -- will be clipped
      vertex (Vertex3 (-100.0) (-100.0) (-100.0) :: Vertex3 GLfloat)
   when (mode == Feedback) $ passThrough (PassThroughValue 2.0)
   beginEnd Points $ do
      normal (Normal3  0.0  0.0 1.0 :: Normal3 GLfloat)
      vertex (Vertex3 50.0 50.0 0.0 :: Vertex3 GLfloat)

instance Show FeedbackInfo where
   showsPrec _ (ThreeDColor (Vertex3 x y z) (Prelude.Right (Color4 r g b a))) =
      foldr (\v -> (.) (showGFloat (Just 2) v . showString " "))
            (showString "")
            [x, y, z, r, g, b, a]
   showsPrec _ _ =
      error "Author is too lazy for a complete Show FeedbackInfo"

instance Show FeedbackToken where
   showsPrec _ (PointToken i) =
      showString "PointToken\n  " . shows i
   showsPrec _ (LineToken i j) =
      showString "LineToken\n  " . shows i . showString "\n  " . shows j
   showsPrec _ (LineResetToken i j) =
      showString "LineResetToken\n  " . shows i . showString "\n  " . shows j
   showsPrec _ (PassThroughToken (PassThroughValue n)) =
      showString "PassThroughToken\n  " . shows n
   showsPrec _ _ =
      error "Author is too lazy for a complete Show FeedbackToken"

-- Write contents of entire buffer.
printBuffer :: GLint -> FeedbackBuffer -> IO ()
printBuffer size buffer = do
   Just tokens <- getFeedbackTokens size buffer
   mapM_ print tokens

display :: DisplayCallback
display = do
   matrixMode Projection
   loadIdentity
   ortho 0.0 100.0 0.0 100.0 0.0 1.0

   clearColor (Color4 0.0 0.0 0.0 0.0)
   clear [ ColorBufferBit ]
   drawGeometry Render

   -- NOTE: This could be moved to myInit for efficiency
   feedBuffer <- makeFeedbackBuffer 1024 ThreeDColor'
   feedbackBuffer feedBuffer
   renderMode Feedback
   drawGeometry Feedback

   size <- renderMode Render
   printBuffer size feedBuffer
   freeFeedbackBuffer feedBuffer

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

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