{- Haskell Dynamics Engine, Copyright (C) 2007 Ruben Henner Zilibowitz All rights reserved. Email: rubenz@cse.unsw.edu.au Web: www.cse.unsw.edu.au/~rubenz This is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License that is include with this package in the file LICENSE-GPL.TXT. -} -- Visualiser -- Created by Ruben Henner Zilibowitz 18/3/2007 module Main where import Data.IORef ( IORef, newIORef, readIORef, modifyIORef, writeIORef ) import System.Exit ( exitWith, ExitCode(ExitSuccess) ) import Graphics.Rendering.OpenGL as OpenGL import Graphics.UI.GLUT as GLUT import Matrix3x3 import Quaternions import Dynamics --(stepWorld,mapArray) import Data.Array import System.CPUTime --import QuadProgInterface(solve_simple_qp) import Objects import World import Data.List(sortBy) import System.IO(hFlush,stdout) --import Debug.Trace(trace) import GLTypeConversion data State = State { leftMouseButton, middleMouseButton, rightMouseButton :: IORef KeyState, mouseLoc, mouseDrag :: IORef Position, world :: IORef World, framesElapsed :: IORef Integer } width = 800 :: Integer height = 600 :: Integer cameraDistance = 40 timeStepSize = 0.009 -- seconds between each frame --- --- make initial state --- makeState :: World -> IO State makeState theWorld = do a <- newIORef Up b <- newIORef Up c <- newIORef Up d <- newIORef (Position 0 0) e <- newIORef (Position 0 0) f <- newIORef theWorld h <- newIORef 0 return $ State { leftMouseButton = a, middleMouseButton = b, rightMouseButton = c, mouseLoc = d, mouseDrag = e, world = f, framesElapsed = h } planeSize = 100 --- --- render a joint --- renderJoint :: Bodies -> Joint -> IO () renderJoint bodies (Joint_ a b (BallSocket loca locb)) = do let bodyA = bodies ! a let bodyB = bodies ! b let locA = (Objects.position bodyA) + (orientation bodyA) .* loca let locB = (Objects.position bodyB) + (orientation bodyB) .* locb renderPrimitive Lines$mapM_ (\(Vec x y z)->vertex$vertex3 x y z) [locA,locB] --- --- render a body --- renderBody :: Body -> IO () renderBody body@(Body_ {geometry = Objects.Sphere r}) = preservingMatrix ( do let (Vec x y z) = Objects.position body translate (vector3 x y z) renderQuadric (QuadricStyle (Just Smooth) NoTextureCoordinates Outside FillStyle) (GLUT.Sphere (realToFrac r) 50 50)) renderBody body@(Body_ {geometry = Objects.Box x y z}) = do preservingMatrix ( do let (Vec px py pz) = Objects.position body let (Quaternions.Q ra rx ry rz) = orientation body translate (vector3 px py pz) let angle = convertGLdouble $ 2*(acos ra) * 180 / pi rotate angle (vector3 rx ry rz) scale (convertGLdouble x) (convertGLdouble y) (convertGLdouble z) renderObject Solid (Cube 2)) renderBody (Body_ {geometry = Objects.Plane a b c}) = do let n@(Vec nx ny nz) = Matrix3x3.normalise (cross (c-a) (b-a)) let e = Matrix3x3.normalise (b - a) let d = cross e n normal (normal3 nx ny nz) renderPrimitive Quads$mapM_ (\(Vec x y z)->vertex$vertex3 x y z) [a+e.*.planeSize,a-d.*.planeSize,a-e.*.planeSize,a+d.*.planeSize] renderBody body@(Body_ {geometry = SphereCappedCylinder radius height}) = do let loc@(Vec px py pz) = Objects.position body let rot@(Quaternions.Q ra rx ry rz) = orientation body preservingMatrix ( do translate (vector3 px py pz) let angle = convertGLdouble $ 2*(acos ra) * 180 / pi rotate angle (vector3 rx ry rz) translate (vector3 0 0 (-0.5*height)) renderQuadric (QuadricStyle (Just Smooth) NoTextureCoordinates Outside FillStyle) (cylinder radius radius height 50 50)) let (Vec px1 py1 pz1) = loc + (rot .* (Vec 0 0 (-0.5*height))) let (Vec px2 py2 pz2) = loc + (rot .* (Vec 0 0 (0.5*height))) preservingMatrix ( do translate (vector3 px1 py1 pz1) renderQuadric (QuadricStyle (Just Smooth) NoTextureCoordinates Outside FillStyle) (GLUT.Sphere (realToFrac radius) 50 50)) preservingMatrix ( do translate (vector3 px2 py2 pz2) renderQuadric (QuadricStyle (Just Smooth) NoTextureCoordinates Outside FillStyle) (GLUT.Sphere (realToFrac radius) 50 50)) renderBody body@(Body_ {geometry = CompoundGeometry g}) = mapM_ renderBody [body {geometry = geom, orientation = (orientation body)*rot, Objects.position = (Objects.position body) + (orientation body).*loc} | (geom,rot,loc) <- g] --- --- display callback --- display :: State -> IO () display state = do clear [ColorBuffer, DepthBuffer] materialAmbient Front $= (Color4 0.3 0.3 0.3 1.0) materialDiffuse Front $= (Color4 0 0 1 1) materialSpecular Front $= (Color4 1 1 1 1) materialShininess Front $= 0.8 * 128 theWorld@(World_ bodies _ joints _ _ _ _ colours) <- readIORef (world state) materialDiffuse Front $= (Color4 (1::GLfloat) 1 1 1) color (Color3 0.0 0.0 (0.0 :: GLfloat)) lighting $= Disabled -- need to disable lighting otherwise lines aren't draw in the right color mapM_ (renderJoint bodies) joints lighting $= Enabled mapM_ (\(body,(r,g,b)) -> (materialDiffuse Front $= color4 r g b 1) >> (renderBody body)) (zip (elems bodies) colours) modifyIORef (world state) (stepWorld timeStepSize) modifyIORef (framesElapsed state) (1+) -- draw the separating line let positions = [Objects.position (bodies!i) | i <- (indices bodies), not (isPlane (bodies!i))] let (start,dir) = separatingLineFunction positions --let (start1,dir1) = lineOfSpan positions color (Color3 1.0 0.0 (1.0 :: GLfloat)) lighting $= Disabled -- need to disable lighting otherwise lines aren't draw in the right color renderPrimitive Lines$mapM_ (\(Vec x y z)->vertex$vertex3 x y z) [start - dir.*.10,start+dir.*.10]--,start1,start1+dir1.*.20] lighting $= Enabled swapBuffers postRedisplay Nothing --- --- reshape callback --- reshape :: Size -> IO () reshape size@(Size w h) = do let h = fromIntegral height / fromIntegral width viewport $= (Position 0 0, size) matrixMode $= Projection loadIdentity frustum (-1) 1 (-h) h 5 60 matrixMode $= Modelview 0 loadIdentity translate (vector3 0 0 (-cameraDistance)) --- --- keyboard and mouse callback --- shakeBody :: Vector RealNum -> Body -> Body shakeBody _ body | (anchored body) = body shakeBody s body = computeAuxiliaryVars (body {momentum = (momentum body) + s .*. (mass body)}) keyboardMouse :: State -> KeyboardMouseCallback keyboardMouse state (Char c) Down _ _ = case c of 't' -> do t <- getCPUTime f <- readIORef (framesElapsed state) putStrLn ("time (ps): " ++ (show t)) putStrLn ("frames: " ++ (show f)) putStrLn ("FPS: " ++ (show ((fromInteger f) / ((fromInteger t) * 1e-12)))) ' ' -> do putStrLn "Shaking..." World_ bodies is js jgs si grav rest colours <- readIORef (world state) let bodies' = mapArray (shakeBody (-grav)) bodies writeIORef (world state) (World_ bodies' is js jgs si grav rest colours) 'p' -> do World_ bodies _ js _ _ grav rest colours <- readIORef (world state) let bodiesList = (elems bodies) ++ (tenpins 4) writeIORef (world state) (makeWorld bodiesList js grav rest colours) 'b' -> do World_ bodies _ js _ _ grav rest colours <- readIORef (world state) let bodiesList = (elems bodies) ++ [bowlingBall] writeIORef (world state) (makeWorld bodiesList js grav rest colours) '\27' -> exitWith ExitSuccess _ -> return () keyboardMouse state (MouseButton LeftButton) buttonState _ pos = do writeIORef (leftMouseButton state) buttonState writeIORef (mouseLoc state) pos keyboardMouse state (MouseButton MiddleButton) buttonState _ pos = do writeIORef (middleMouseButton state) buttonState writeIORef (mouseLoc state) pos keyboardMouse state (MouseButton RightButton) buttonState _ pos = do writeIORef (rightMouseButton state) buttonState writeIORef (mouseLoc state) pos keyboardMouse _ _ _ _ _ = return () --- --- motion callback --- motion :: State -> MotionCallback motion state pos = do oldPos <- readIORef (mouseLoc state) writeIORef (mouseLoc state) pos writeIORef (mouseDrag state) ((\(Position a b) (Position x y) -> Position (a-x) (b-y)) pos oldPos) leftButton <- readIORef (leftMouseButton state) middleButton <- readIORef (middleMouseButton state) rightButton <- readIORef (rightMouseButton state) (Position mousex mousey) <- readIORef (mouseDrag state) case leftButton of Down -> do rotate (fromIntegral mousex / 10) (vector3 0 1 (0 :: Double)) rotate (fromIntegral mousey / 10) (vector3 1 0 (0 :: Double)) Up -> putStr "" case middleButton of Down -> translate (vector3 (fromIntegral mousex / 20) (0.0 :: Double) (fromIntegral mousey / 20)) Up -> putStr "" case rightButton of Down -> translate (vector3 (fromIntegral mousex / 20) (fromIntegral mousey / 20) (0.0 :: Double)) Up -> putStr "" --- --- main --- main :: IO () main = do (_progName, args) <- getArgsAndInitialize initialDisplayMode $= [ RGBMode, WithDepthBuffer, DoubleBuffered ] initialWindowPosition $= Position 0 0 initialWindowSize $= Size (fromInteger width) (fromInteger height) createWindow _progName putStrLn "Welcome to the Haskell Dynamics Engine." state <- makeState =<< getWorld printCommands myInit displayCallback $= display state reshapeCallback $= Just reshape keyboardMouseCallback $= Just (keyboardMouse state) motionCallback $= Just (motion state) clearColor $= backgroundColor clear [ColorBuffer, DepthBuffer] mainLoop getWorld :: IO World getWorld = do putStrLn "Please choose from one of the following scenes for a demo." putStrLn (concat [(show i) ++ " - " ++ name ++ "\n" | (i,(name,_,_,_,_,_)) <- zip [0..] demoScenes]) putStr "? " hFlush stdout str <- getLine let choice = (read str) :: Int let (_,bodies,joints,gravity,restitution,colours) = demoScenes !! choice return (makeWorld bodies joints gravity restitution colours) printCommands :: IO () printCommands = do putStrLn "Press to bump all objects in the opposite direction to gravity." putStrLn "Press t for the average frames per second to be printed to the console." putStrLn "Press p to insert 10 capsules into the world in a triangle (like in ten-pin bowling)." putStrLn "Press b to fire a bowling ball." putStrLn "Press to quit." putStrLn "Left mouse button and drag to rotate view" putStrLn "Middle mouse button and drag to pan in the xz plane" putStrLn "Right mouse button and drag to pan in the xy plane" --backgroundColor = Color4 0.0 0.0 0.0 0.0 backgroundColor = Color4 1 1 1 1 --- --- Initialize depth buffer, projection matrix, light source, and lighting --- model. Do not specify a material property here. --- myInit :: IO () myInit = do ambient (Light 0) $= Color4 0 0 0 1 diffuse (Light 0) $= Color4 1 1 1 1 OpenGL.position (Light 0) $= Vertex4 3 3 3 3 lightModelAmbient $= Color4 0.2 0.2 0.2 1 lightModelLocalViewer $= Disabled frontFace $= CW lighting $= Enabled light (Light 0) $= Enabled autoNormal $= Enabled --normalize $= Enabled depthFunc $= Just Less --shadeModel $= Flat return () {- --- --- readWorld --- readWorld :: FilePath -> IO World readWorld path = do worldDesc <- do {f <- readFile path; return (subName f)} putStrLn ("Attempting to read: " ++ worldDesc) let (bodyDescList,jointsList) = read worldDesc :: ([BodyDescription],[Joint]) let bodyList = [makeBody geom mass pos rot vel rvel anchor | (BodyDesc geom mass pos rot vel rvel anchor) <- bodyDescList] return (makeWorld bodyList jointsList) where subName ('B':'o':'d':'y':cs) = "BodyDesc" ++ (subName cs) subName (c:cs) = c : (subName cs) subName [] = [] data BodyDescription = BodyDesc Geometry RealNum (Vector RealNum) (Quaternion RealNum) (Vector RealNum) (Vector RealNum) Bool deriving (Read, Show) -} --- makeWorld --- Places all bodies into an array and forms a single island containing all the anchored bodies makeWorld :: [Body] -> [Joint] -> Vector RealNum -> RealNum -> [RGBColour] -> World makeWorld bodiesList joints gravity restitution colours = World_ bodies ([anchors] ++ joined ++ others) joints (makeJointGroups bodies joints) sortedIntervals gravity restitution colours where anchors = [i | (i,b) <- assocs bodies, anchored b] joined = [[a,b] | (Joint_ a b (BallSocket _ _)) <- joints] others = [[i] | i <- (indices bodies), i `notElem` anchors, i `notElem` (concat joined)] bodies = listArray (1,length bodiesList) bodiesList sortedIntervals = sortBy compareSnds [(i,xInterval (bodies!i)) | i <- (indices bodies)]