KeyboardAndMouseAnimation.hs

-- KeyboardAndMouseAnimation.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 Quads $ 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]

display angle location =
 clear [ColorBuffer] >>
 loadIdentity >>
 get location >>= \(x,y) ->
 translate (Vector3 x y 0) >>
 preservingMatrix aux1 >>
 swapBuffers
 where
  aux0 (x,y,z) =
   color (Color3 ((x+1.0)/2.0) ((y+1.0)/2.0) ((z+1.0)/2.0)) >>
   translate (Vector3 x y z) >>
   cube (0.1::GLfloat)
  aux1 =
   get angle >>= \a ->
   rotate a (Vector3 0 0 (1::GLfloat)) >>
   scale 0.7 0.7 (0.7::GLfloat) >>
   mapM_ (\p@(x,y,z) -> preservingMatrix $ aux0 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.001),y+(getIncrement down up 0.001)) >>
 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 -> Key -> KeyState -> Modifiers -> Position-> IO ()
keyboardMouse point upKey downKey leftKey rightKey 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
  _ -> return ()

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

main =
 getArgsAndInitialize >>= \(programName,_) ->
 initialDisplayMode $= [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) >>
 motionCallback $= Just (mouseMotion point) >>
 idleCallback $= Just (idle upKey downKey leftKey rightKey angle delta point) >>
 displayCallback $= (display angle point) >>
 mainLoop