{-
   Stencil.hs  (adapted from stencil.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 the stencil buffer for
   masking nonrectangular regions.  
   Whenever the window is redrawn, a value of 1 is drawn 
   into a diamond-shaped region in the stencil buffer.  
   Elsewhere in the stencil buffer, the value is 0.
   Then a blue sphere is drawn where the stencil value is 1,
   and yellow torii are drawn where the stencil value is not 1.
-}

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

import GL
import GLU
import Graphics.UI.GLUT

yellowMat, blueMat :: DisplayList
yellowMat = DisplayList 1
blueMat   = DisplayList 2

myInit :: IO ()
myInit = do
   newEndList yellowMat Compile $ mapM_ (material Front) [
      MaterialColor Diffuse  (Color4 0.7 0.7 0.0 1.0),
      MaterialColor Specular (Color4 1.0 1.0 1.0 1.0),
      Shininess 64 ]

   newEndList blueMat Compile $ mapM_ (material Front) [
      MaterialColor Diffuse  (Color4 0.1 0.1 0.7 1.0),
      MaterialColor Specular (Color4 0.1 1.0 1.0 1.0),
      Shininess 45 ]

   light (Light 0) (Position (Vertex4 1.0 1.0 1.0 0.0))

   enable (Light 0)
   enable Lighting
   enable DepthTest

   clearStencil 0x0
   enable StencilTest

-- Draw a sphere in a diamond-shaped section in the
-- middle of a window with 2 torii.
display :: DisplayCallback
display = do
   clear [ColorBufferBit, DepthBufferBit]

   -- draw blue sphere where the stencil is 1
   stencilFunc GL.Equal 0x1 0x1
   stencilOp Keep Keep Keep
   callList blueMat
   renderObject Solid (Graphics.UI.GLUT.Sphere 0.5 15 15)

   -- draw the tori where the stencil is not 1
   stencilFunc GL.Notequal 0x1 0x1
   pushMatrix
   rotate (45 :: GLfloat) (Vector3 0 0 1)
   rotate (45 :: GLfloat) (Vector3 0 1 0)
   callList yellowMat
   renderObject Solid (Torus 0.275 0.85 15 15)
   pushMatrix
   rotate (90 :: GLfloat) (Vector3 1 0 0)
   renderObject Solid (Torus 0.275 0.85 15 15)
   popMatrix
   popMatrix

-- Whenever the window is reshaped, redefine the 
-- coordinate system and redraw the stencil area.
reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)

   -- create a diamond shaped stencil area
   matrixMode Projection
   loadIdentity
   let wf = fromIntegral w
       hf = fromIntegral h
   if (w <= h)
      then ortho2D (-3.0) 3.0 (-3.0*hf/wf) (3.0*hf/wf)
      else ortho2D (-3.0*wf/hf) (3.0*wf/hf) (-3.0) 3.0
   matrixMode Modelview
   loadIdentity

   clear [StencilBufferBit]
   stencilFunc Always 0x1 0x1
   stencilOp Replace' Replace' Replace'
   beginEnd Quads $ mapM_ vertex [
      Vertex2 (-1) 0, Vertex2 0 1 , Vertex2 1 0, Vertex2 0 (-1 :: GLfloat) ]

   matrixMode Projection
   loadIdentity
   perspective 45.0 (wf/hf) 3.0 7.0
   matrixMode Modelview
   loadIdentity
   translate (Vector3 0 0 (-5) :: Vector3 GLfloat)

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

-- Main Loop
-- Be certain to request stencil bits.
main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB, Graphics.UI.GLUT.Depth, Graphics.UI.GLUT.Stencil ]
   setInitialWindowSize (WindowSize 400 400)
   setInitialWindowPosition (WindowPosition 100 100)
   createWindow progName
   myInit
   setReshapeCallback  (Just reshape)
   setDisplayCallback display
   setKeyboardMouseCallback (Just keyboard)
   mainLoop
