KeyboardAndMouse3DAnimation.hs

-- KeyboardAndMouse3DAnimation.hs
-- Inspired by:
-- http://cvs.haskell.org/Hugs/pages/libraries/GLUT/Graphics-UI-GLUT-Callbacks-Window.html
-- http://www.haskell.org/haskellwiki/OpenGLTutorial2

module Main(main) where

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT
import Data.IORef

vertify3 :: [(GLfloat,GLfloat,GLfloat)] -> IO ()
vertify3 verts = sequence_ $ map (\(a,b,c) -> vertex $ Vertex3 a b c) verts

cube w = renderPrimitive Polygon $ vertify3 $
 [( w, w, w), ( w, w,-w), ( w,-w,-w), ( w,-w, w),
  ( w, w, w), ( w, w,-w), (-w, w,-w), (-w, w, w),
  ( w, w, w), ( w,-w, w), (-w,-w, w), (-w, w, w),
  (-w, w, w), (-w, w,-w), (-w,-w,-w), (-w,-w, w),
  ( w,-w, w), ( w,-w,-w), (-w,-w,-w), (-w,-w, w),
  ( w, w,-w), ( w,-w,-w), (-w,-w,-w), (-w, w,-w)]

cubeFrame w = renderPrimitive Lines $ vertify3 $
 [( w,-w, w), ( w, w, w),  ( w, w, w), (-w, w, w),
  (-w, w, w), (-w,-w, w),  (-w,-w, w), ( w,-w, w),
  ( w,-w, w), ( w,-w,-w),  ( w, w, w), ( w, w,-w),
  (-w, w, w), (-w, w,-w),  (-w,-w, w), (-w,-w,-w),
  ( w,-w,-w), ( w, w,-w),  ( w, w,-w), (-w, w,-w),
  (-w, w,-w), (-w,-w,-w),  (-w,-w,-w), ( w,-w,-w) ]

points :: GLfloat -> [(GLfloat,GLfloat,GLfloat)]
points n = map (\k -> (sin(2*pi*k/n),cos(2*pi*k/n),0.0)) [1..n]

cube3d :: GLfloat -> Color3 GLfloat -> Color3 GLfloat -> IO ()
cube3d size backgroundColor lineColor =
 color backgroundColor >>
 cube size >>
 color lineColor >>
 cubeFrame size

display angle location =
 clear [ColorBuffer,DepthBuffer] >>
 loadIdentity >>
 color (Color3 (1.0::GLfloat) 1.0 1.0) >>
 cube (0.3::GLfloat) >>
 get location >>= \(x,y) ->
 translate (Vector3 x y 0) >>
 get angle >>= \a ->
 rotate a (Vector3 0 0.1 (1::GLfloat)) >>
 preservingMatrix drawPoints >>
 cube3d (0.2::GLfloat) (Color3 (1.0::GLfloat) 0.0 0.0) (Color3 (0.0::GLfloat) 0.0 0.0) >>
 swapBuffers
 where
  drawPoint (x,y,z) =
   translate (Vector3 x y z) >>
   cube3d (0.2::GLfloat) (Color3 ((x+1.0)/2.0) ((y+1.0)/2.0) ((z+1.0)/2.0)) (Color3 (0.0::GLfloat) 0.0 0.0)
  drawPoints =
   mapM_ (\p@(x,y,z) -> preservingMatrix $ drawPoint p) (points 24)

getIncrement :: Bool -> Bool -> GLfloat -> GLfloat
getIncrement negativeKey positiveKey increment =
 (if negativeKey then (-increment) else 0.0) + (if positiveKey then increment else 0.0)

limit x x0 x1 =
 if x < x0 then x0 else
  if x > x1 then x1 else x

limitPoint point =
 get point >>= \(x,y) ->
 point $= (limit x (-1.0) 1.0, limit y (-1.0) 1.0)

idle upKey downKey leftKey rightKey angle delta location =
 get location >>= \(x,y) ->
 get leftKey >>= \left ->
 get rightKey >>= \right ->
 get upKey >>= \up ->
 get downKey >>= \down ->
 location $= (x+(getIncrement left right 0.01),y+(getIncrement down up 0.01)) >>
 limitPoint location >>
 get angle >>= \a ->
 get delta >>= \d ->
 angle $=! (a+d) >>
 postRedisplay Nothing

reshape s@(Size w h) =
 viewport $= (Position 0 0, s)

fromGLintToGLfloat i = (fromIntegral i)::GLfloat

getCanvasSize =
 get viewport >>= \(Position x y,Size width height) ->
 return (fromGLintToGLfloat width,fromGLintToGLfloat height)

fromMousePointToCanvasPoint mp@(mx,my) =
 getCanvasSize >>= \(width,height) ->
 return (2.0*(fromGLintToGLfloat mx)/width-1.0,(-2.0)*(fromGLintToGLfloat my)/height+1.0)

keyboardMouse :: IORef (GLfloat, GLfloat) -> IORef Bool -> IORef Bool ->
 IORef Bool -> IORef Bool -> IORef GLfloat -> Key -> KeyState -> Modifiers ->
 Position-> IO ()
keyboardMouse point upKey downKey leftKey rightKey delta key keyState modifiers position@(Position x y) =
 case key of
  MouseButton LeftButton ->
   fromMousePointToCanvasPoint (x,y) >>= \(nx,ny) ->
   point $= (nx,ny)
  SpecialKey KeyLeft ->
   leftKey $= keyState == Down
  SpecialKey KeyRight ->
   rightKey $= keyState == Down
  SpecialKey KeyUp ->
   upKey $= keyState == Down
  SpecialKey KeyDown ->
   downKey $= keyState == Down
  Char ' ' ->
   get delta >>= \d ->
   if keyState == Down then delta $= -d else return ()
  _ -> return ()

mouseMotion point position@(Position x y) =
 fromMousePointToCanvasPoint (x,y) >>= \(nx,ny) ->
  point $= (nx,ny)

main =
 getArgsAndInitialize >>= \(programName,_) ->
 initialDisplayMode $= [WithDepthBuffer,DoubleBuffered] >>
 createWindow "Robotic Arm" >>
 reshapeCallback $= Just reshape >>
 newIORef (0.0::GLfloat) >>= \angle ->
 newIORef (0.1::GLfloat) >>= \delta ->
 newIORef (0::GLfloat,0::GLfloat) >>= \point ->
 newIORef (False) >>= \upKey ->
 newIORef (False) >>= \downKey ->
 newIORef (False) >>= \leftKey ->
 newIORef (False) >>= \rightKey ->
 keyboardMouseCallback $= Just (keyboardMouse point upKey downKey leftKey rightKey delta) >>
 motionCallback $= Just (mouseMotion point) >>
 idleCallback $= Just (idle upKey downKey leftKey rightKey angle delta point) >>
 displayCallback $= (display angle point) >>
 mainLoop