{-
   Alpha.hs (adapted from alpha.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 draws several overlapping filled polygons
   to demonstrate the effect order has on alpha blending results.
   Use the 't' key to toggle the order of drawing polygons.
-}

import Data.Char   ( toLower )
import Data.IORef  ( IORef, newIORef, readIORef, modifyIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )

import GL
import GLU
import Graphics.UI.GLUT

-- Initialize alpha blending function.
myInit :: IO ()
myInit = do
   enable Blend'
   blendFunc SrcAlpha OneMinusSrcAlpha
   shadeModel GL.Flat
   clearColor (Color4 0.0 0.0 0.0 0.0)

drawLeftTriangle :: IO ()
drawLeftTriangle =
   -- draw yellow triangle on LHS of screen
   beginEnd Triangles $ do
      color (Color4 1.0 1.0 0.0 0.75 :: Color4 GLfloat)
      mapM_ vertex [ Vertex2 0.1 0.9, Vertex2 0.1 0.1, Vertex2 0.7 (0.5 :: GLfloat) ]

drawRightTriangle :: IO ()
drawRightTriangle =
   -- draw cyan triangle on RHS of screen
   beginEnd Triangles $ do
      color (Color4 0.0 1.0 1.0 0.75 :: Color4 GLfloat)
      mapM_ vertex [ Vertex2 0.9 0.9, Vertex2 0.3 0.5, Vertex2 0.9 (0.1 :: GLfloat) ]

display :: IORef Bool -> DisplayCallback
display leftFirst = do
   clear [ColorBufferBit]
   lf <- readIORef leftFirst
   if lf
      then do drawLeftTriangle; drawRightTriangle
      else do drawRightTriangle; drawLeftTriangle
   flush

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   let wf = fromIntegral w
       hf = fromIntegral h
   if (w <= h)
      then ortho2D 0.0 1.0 0.0 (1.0*hf/wf)
      else ortho2D 0.0 (1.0*wf/hf) 0.0 1.0

keyboard :: IORef Bool -> KeyboardMouseCallback
keyboard leftFirst (Char c) Down _ _ = case toLower c of
   't'   -> do modifyIORef leftFirst not; postRedisplay
   '\27' -> exitWith ExitSuccess
   _     -> return ()
keyboard _ _ _ _ _ = return ()

-- Main Loop
-- Open window with initial window size, title bar, 
-- RGBA display mode, and handle input events.
main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB ]
   setInitialWindowSize (WindowSize 200 200)
   createWindow progName
   myInit
   setReshapeCallback (Just reshape)
   leftFirst <- newIORef True
   setKeyboardMouseCallback (Just (keyboard leftFirst))
   setDisplayCallback (display leftFirst)
   mainLoop
