{-
   Polys.hs (adapted from polys.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 polygon stippling.
-}

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

import GL
import GLU
import Graphics.UI.GLUT

fly :: [GLubyte]
fly = [0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
       0x03, 0x80, 0x01, 0xC0, 0x06, 0xC0, 0x03, 0x60,
       0x04, 0x60, 0x06, 0x20, 0x04, 0x30, 0x0C, 0x20,
       0x04, 0x18, 0x18, 0x20, 0x04, 0x0C, 0x30, 0x20,
       0x04, 0x06, 0x60, 0x20, 0x44, 0x03, 0xC0, 0x22,
       0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22,
       0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22,
       0x44, 0x01, 0x80, 0x22, 0x44, 0x01, 0x80, 0x22,
       0x66, 0x01, 0x80, 0x66, 0x33, 0x01, 0x80, 0xCC,
       0x19, 0x81, 0x81, 0x98, 0x0C, 0xC1, 0x83, 0x30,
       0x07, 0xe1, 0x87, 0xe0, 0x03, 0x3f, 0xfc, 0xc0,
       0x03, 0x31, 0x8c, 0xc0, 0x03, 0x33, 0xcc, 0xc0,
       0x06, 0x64, 0x26, 0x60, 0x0c, 0xcc, 0x33, 0x30,
       0x18, 0xcc, 0x33, 0x18, 0x10, 0xc4, 0x23, 0x08,
       0x10, 0x63, 0xC6, 0x08, 0x10, 0x30, 0x0c, 0x08,
       0x10, 0x18, 0x18, 0x08, 0x10, 0x00, 0x00, 0x08]

halftone :: [GLubyte]
halftone = take 128 (cycle [0xAA, 0xAA, 0xAA, 0xAA, 0x55, 0x55, 0x55, 0x55])

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

   -- draw one solid, unstippled rectangle,
   -- then two stippled rectangles
   rect (Vertex2 ( 25 :: GLfloat) 25) (Vertex2 125 125)
   enable PolygonStipple
   polygonStipple fly
   rect (Vertex2 (125 :: GLfloat) 25) (Vertex2 225 125)
   polygonStipple halftone
   rect (Vertex2 (225 :: GLfloat) 25) (Vertex2 325 125)
   disable PolygonStipple

   flush

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

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   ortho2D 0.0 (fromIntegral w) 0.0 (fromIntegral h)

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

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