{-
   Image.hs  (adapted from image.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 drawing pixels and shows the effect
   of drawPixels, copyPixels, and pixelZoom.
   Interaction: moving the mouse while pressing the mouse button
   will copy the image in the lower-left corner of the window
   to the mouse position, using the current pixel zoom factors.
   There is no attempt to prevent you from drawing over the original
   image.  If you press the 'r' key, the original image and zoom
   factors are reset.  If you press the 'z' or 'Z' keys, you change
   the zoom factors.
-}

import Control.Monad ( liftM )
import Data.Bits     ( (.&.) )
import Data.IORef    ( IORef, newIORef, readIORef, writeIORef )
import System.Exit   ( exitWith, ExitCode(ExitSuccess) )

import GL
import GLU
import Graphics.UI.GLUT

-- Create checkerboard image
checkImageWidth, checkImageHeight :: GLsizei
checkImageWidth  = 64
checkImageHeight = 64

makeCheckImage :: IO PixelDescriptor
makeCheckImage = do
   buf <- newArray [ Color4 c c c 255 |
                     i <- [ 0 .. checkImageHeight - 1 ],
                     j <- [ 0 .. checkImageWidth  - 1 ],
                     let c | (i .&. 0x8) == (j .&. 0x8) = 0 :: GLubyte
                           | otherwise                  = 255 ]
   return (PixelDescriptor GL.Rgba UnsignedByte (castPtr buf))

myInit :: IO PixelDescriptor
myInit = do
   clearColor (Color4 0 0 0 0)
   shadeModel GL.Flat
   pixelStore Unpack (Alignment 1)
   makeCheckImage

display :: PixelDescriptor -> DisplayCallback
display checkImage = do
   clear [ ColorBufferBit ]
   rasterPos (RasterPos2 0 (0 :: GLint))
   drawPixels checkImageWidth checkImageHeight checkImage
   flush

reshape :: IORef GLint -> ReshapeCallback
reshape height (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   writeIORef height (fromIntegral h)
   matrixMode Projection
   loadIdentity
   ortho2D 0 (fromIntegral w) 0 (fromIntegral h)
   matrixMode Modelview
   loadIdentity

motion :: IORef GLfloat -> IORef GLint -> MotionCallback
motion zoomFactor height (WindowPosition x y) = do
   h <- readIORef height
   let screenY = h - fromIntegral y
   rasterPos (RasterPos2 (fromIntegral x) screenY)
   z <- readIORef zoomFactor
   pixelZoom z z
   copyPixels 0 0 checkImageWidth checkImageHeight Color
   pixelZoom 1 1
   flush

resetZoomFactor :: IORef GLfloat -> IO ()
resetZoomFactor zoomFactor = do
   writeIORef zoomFactor 1.0
   postRedisplay
   putStrLn "zoomFactor reset to 1.0"

incZoomFactor :: IORef GLfloat -> GLfloat -> IO ()
incZoomFactor zoomFactor inc = do
   z <- liftM (max 0.5 . min 3.0 . (+ inc)) (readIORef zoomFactor)
   writeIORef zoomFactor z
   putStrLn ("zoomFactor is now " ++ show z)

keyboard :: IORef GLfloat -> KeyboardMouseCallback
keyboard zoomFactor (Char 'r')   Down _   _ = resetZoomFactor zoomFactor
keyboard zoomFactor (Char 'R')   Down _   _ = resetZoomFactor zoomFactor
keyboard zoomFactor (Char 'z')   Down _   _ = incZoomFactor   zoomFactor   0.5
keyboard zoomFactor (Char 'Z')   Down _   _ = incZoomFactor   zoomFactor (-0.5)
keyboard _          (Char '\27') Down _   _ = exitWith ExitSuccess
keyboard _          _            _    _   _ = return ()

main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB ]
   setInitialWindowSize (WindowSize 250 250)
   setInitialWindowPosition (WindowPosition 100 100)
   createWindow progName
   checkImage <- myInit
   setDisplayCallback (display checkImage)
   height <- newIORef 250
   setReshapeCallback (Just (reshape height))
   zoomFactor <- newIORef 1.0
   setKeyboardMouseCallback (Just (keyboard zoomFactor))
   setMotionCallback (Just (motion zoomFactor height))
   mainLoop
