{-
   BezCurve.hs (adapted from bezcurve.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 uses evaluators to draw a Bezier curve.
-}

import Data.List   ( genericLength )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )

import GL
import Graphics.UI.GLUT

ctrlPoints :: [Vertex3 GLfloat]
ctrlPoints = [ Vertex3 (-4.0)(-4.0) 0.0, Vertex3 (-2.0) 4.0 0.0,
               Vertex3   2.0 (-4.0) 0.0, Vertex3   4.0  4.0 0.0 ]

myInit :: IO ()
myInit = do
   clearColor (Color4 0.0 0.0 0.0 0.0)
   shadeModel Flat
   withArray ctrlPoints $ map1 Map1Vertex3 (0.0 :: GLfloat) 1.0 3 (genericLength ctrlPoints) . castPtr
   enable Map1Vertex3

display :: DisplayCallback
display = do
   clear [ColorBufferBit]
   color (Color3 1.0 1.0 1.0 :: Color3 GLfloat)
   beginEnd LineStrip $ mapM_ evalCoord1 [ i/30.0 :: GLfloat | i <- [0..30] ]
   -- The following code displays the control points as dots.
   pointSize 5.0
   color (Color3 1.0 1.0 0.0 :: Color3 GLfloat)
   beginEnd Points $ mapM_ vertex ctrlPoints
   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 ortho (-5.0) 5.0 (-5.0*hf/wf) (5.0*hf/wf) (-5.0) 5.0
      else ortho (-5.0*wf/hf) (5.0*wf/hf) (-5.0) 5.0 (-5.0) 5.0
   matrixMode Modelview
   loadIdentity

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

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