{-
   Model.hs (adapted from model.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 modeling transformations
-}

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

import GL
import Graphics.UI.GLUT

myInit :: IO ()
myInit = do
   clearColor (Color4 0.0 0.0 0.0 0.0)
   shadeModel Flat

drawTriangle :: IO ()
drawTriangle =
   beginEnd LineLoop $ do
   vertex (Vertex2    0.0  ( 25.0 :: GLfloat))
   vertex (Vertex2   25.0  (-25.0 :: GLfloat))
   vertex (Vertex2 (-25.0) (-25.0 :: GLfloat))


display :: DisplayCallback
display = do
   clear [ ColorBufferBit ]
   color (Color3 1.0 1.0 (1.0 :: GLfloat))

   loadIdentity
   color (Color3 1.0 1.0 (1.0 :: GLfloat))
   drawTriangle

   enable LineStipple
   lineStipple 1 0xF0F0
   loadIdentity
   translate (Vector3 (-20.0) 0.0 (0.0 :: GLfloat))
   drawTriangle

   lineStipple 1 0xF00F
   loadIdentity
   scale 1.5 0.5 (1.0 :: GLfloat)
   drawTriangle

   lineStipple 1 0x8888
   loadIdentity
   rotate (90.0 :: GLfloat) (Vector3 0.0 0.0 1.0)
   drawTriangle
   disable LineStipple

   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 (-50.0) 50.0 (-50.0*hf/wf) (50.0*hf/wf) (-1.0) 1.0
      else ortho (-50.0*wf/hf) (50.0*wf/hf) (-50.0) 50.0 (-1.0) 1.0
   matrixMode Modelview

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
