module Vis ( vis
, VisObject(..)
, VisColor(..)
, Camera0(..)
) where
import Data.IORef ( newIORef )
import System.Exit ( exitSuccess )
import Graphics.UI.GLUT
import Data.Time.Clock
import Control.Concurrent
import Control.Monad
import Graphics.Rendering.OpenGL.Raw( glBegin, glEnd, gl_QUADS, gl_QUAD_STRIP, gl_TRIANGLES, glVertex3f, glVertex3d, glNormal3d, gl_TRIANGLE_FAN )
import SpatialMath
import Vis.Camera
data VisColor = Rgb GLfloat GLfloat GLfloat
| Rgba GLfloat GLfloat GLfloat GLfloat
setColor :: VisColor -> IO ()
setColor (Rgb r g b) = color (Color3 r g b)
setColor (Rgba r g b a) = color (Color4 r g b a)
setMaterialDiffuse :: VisColor -> GLfloat -> IO ()
setMaterialDiffuse (Rgb r g b) a = materialDiffuse Front $= Color4 r g b a
setMaterialDiffuse (Rgba r g b a) _ = materialDiffuse Front $= Color4 r g b a
data VisObject a = VisCylinder (a,a) (Xyz a) (Quat a) VisColor
| VisBox (a,a,a) (Xyz a) (Quat a) VisColor
| VisLine [Xyz a] VisColor
| VisArrow (a,a) (Xyz a) (Xyz a) VisColor
| VisAxes (a,a) (Xyz a) (Quat a)
| VisPlane (Xyz a) a VisColor VisColor
| VisTriangle (Xyz a) (Xyz a) (Xyz a) VisColor
| VisQuad (Xyz a) (Xyz a) (Xyz a) (Xyz a) VisColor
instance Functor VisObject where
fmap f (VisCylinder (x,y) xyz quat col) = VisCylinder (f x, f y) (fmap f xyz) (fmap f quat) col
fmap f (VisBox (x,y,z) xyz quat col) = VisBox (f x, f y, f z) (fmap f xyz) (fmap f quat) col
fmap f (VisLine xyzs col) = VisLine (map (fmap f) xyzs) col
fmap f (VisArrow (x,y) xyz0 xyz1 col) = VisArrow (f x, f y) (fmap f xyz0) (fmap f xyz1) col
fmap f (VisAxes (x,y) xyz quat) = VisAxes (f x, f y) (fmap f xyz) (fmap f quat)
fmap f (VisPlane xyz x col0 col1) = VisPlane (fmap f xyz) (f x) col0 col1
fmap f (VisTriangle x0 x1 x2 col) = VisTriangle (fmap f x0) (fmap f x1) (fmap f x2) col
fmap f (VisQuad x0 x1 x2 x3 col) = VisQuad (fmap f x0) (fmap f x1) (fmap f x2) (fmap f x3) col
myGlInit :: String -> IO ()
myGlInit progName = do
initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
Size x y <- get screenSize
putStrLn $ "screen resolution " ++ show x ++ "x" ++ show y
let intScale d i = round $ d*(realToFrac i :: Double)
x0 = intScale 0.3 x
xf = intScale 0.95 x
y0 = intScale 0.05 y
yf = intScale 0.95 y
initialWindowSize $= Size (xf x0) (yf y0)
initialWindowPosition $= Position (fromIntegral x0) (fromIntegral y0)
_ <- createWindow progName
clearColor $= Color4 0 0 0 0
shadeModel $= Smooth
depthFunc $= Just Less
lighting $= Enabled
light (Light 0) $= Enabled
ambient (Light 0) $= Color4 1 1 1 1
materialDiffuse Front $= Color4 0.5 0.5 0.5 1
materialSpecular Front $= Color4 1 1 1 1
materialShininess Front $= 25
colorMaterial $= Just (Front, Diffuse)
drawObjects :: [VisObject GLdouble] -> IO ()
drawObjects = mapM_ drawObject
where
drawObject :: VisObject GLdouble -> IO ()
drawObject (VisTriangle (Xyz x0 y0 z0) (Xyz x1 y1 z1) (Xyz x2 y2 z2) col) =
preservingMatrix $ do
setMaterialDiffuse col 1
setColor col
glBegin gl_TRIANGLES
glVertex3d x0 y0 z0
glVertex3d x1 y1 z1
glVertex3d x2 y2 z2
glEnd
drawObject (VisQuad (Xyz x0 y0 z0) (Xyz x1 y1 z1) (Xyz x2 y2 z2) (Xyz x3 y3 z3) col) =
preservingMatrix $ do
setMaterialDiffuse col 1
setColor col
glBegin gl_QUADS
glVertex3d x0 y0 z0
glVertex3d x1 y1 z1
glVertex3d x2 y2 z2
glVertex3d x3 y3 z3
glEnd
drawObject (VisCylinder (height,radius) (Xyz x y z) (Quat q0 q1 q2 q3) col) =
preservingMatrix $ do
setMaterialDiffuse col 1
setColor col
translate (Vector3 x y z :: Vector3 GLdouble)
rotate (2 * acos q0 *180/pi :: GLdouble) (Vector3 q1 q2 q3)
let nslices = 10 :: Int
nstacks = 10 :: Int
sinCosTable = map (\q -> (sin q, cos q)) angles
where
angle = 2*pi/(fromIntegral nslices)
angles = reverse $ map ((angle*) . fromIntegral) [0..(nslices+1)]
glBegin gl_TRIANGLE_FAN
glNormal3d 0 0 (1)
glVertex3d 0 0 0
mapM_ (\(s,c) -> glVertex3d (c*radius) (s*radius) 0) sinCosTable
glEnd
glBegin gl_TRIANGLE_FAN
glNormal3d 0 0 1
glVertex3d 0 0 height
mapM_ (\(s,c) -> glVertex3d (c*radius) (s*radius) height) (reverse sinCosTable)
glEnd
let
zSteps = map (\k -> (fromIntegral k)*height/(fromIntegral nstacks)) [0..nstacks]
drawSlice z0 z1 (s,c) = do
glNormal3d c s 0
glVertex3d (c*radius) (s*radius) z0
glVertex3d (c*radius) (s*radius) z1
drawSlices (z0,z1) = do
glBegin gl_QUAD_STRIP
mapM_ (drawSlice z0 z1) sinCosTable
glEnd
mapM_ drawSlices $ zip (init zSteps) (tail zSteps)
drawObject (VisBox (dx,dy,dz) (Xyz x y z) (Quat q0 q1 q2 q3) col) =
preservingMatrix $ do
setMaterialDiffuse col 0.1
setColor col
translate (Vector3 x y z :: Vector3 GLdouble)
rotate (2 * acos q0 *180/pi :: GLdouble) (Vector3 q1 q2 q3)
normalize $= Enabled
scale dx dy dz
renderObject Solid (Cube 1)
normalize $= Disabled
drawObject (VisLine path col) =
preservingMatrix $ do
lighting $= Disabled
setColor col
renderPrimitive LineStrip $ mapM_ (\(Xyz x' y' z') -> vertex$Vertex3 x' y' z') path
lighting $= Enabled
drawObject (VisPlane (Xyz x y z) offset col1 col2) =
preservingMatrix $ do
let norm = 1/(sqrt $ x*x + y*y + z*z)
x' = x*norm
y' = y*norm
z' = z*norm
r = 10
n = 5
eps = 0.01
translate (Vector3 (offset*x') (offset*y') (offset*z') :: Vector3 GLdouble)
rotate ((acos z')*180/pi :: GLdouble) (Vector3 (y') x' 0)
mapM_ drawObject $ concat [[ VisLine [Xyz (r) y0 eps, Xyz r y0 eps] col1
, VisLine [Xyz x0 (r) eps, Xyz x0 r eps] col1
] | x0 <- [r,r+r/n..r], y0 <- [r,r+r/n..r]]
mapM_ drawObject $ concat [[ VisLine [Xyz (r) y0 (eps), Xyz r y0 (eps)] col1
, VisLine [Xyz x0 (r) (eps), Xyz x0 r (eps)] col1
] | x0 <- [r,r+r/n..r], y0 <- [r,r+r/n..r]]
glBegin gl_QUADS
setColor col2
let r' = realToFrac r
glVertex3f r' r' 0
glVertex3f (r') r' 0
glVertex3f (r') (r') 0
glVertex3f r' (r') 0
glEnd
drawObject (VisArrow (size, aspectRatio) (Xyz x0 y0 z0) (Xyz x y z) col) =
preservingMatrix $ do
let numSlices = 8
numStacks = 15
cylinderRadius = 0.5*size/aspectRatio
cylinderHeight = size
coneRadius = 2*cylinderRadius
coneHeight = 2*coneRadius
rotAngle = acos(z/(sqrt(x*x + y*y + z*z) + 1e-15))*180/pi :: GLdouble
rotAxis = Vector3 (y) x 0
translate (Vector3 x0 y0 z0 :: Vector3 GLdouble)
rotate rotAngle rotAxis
drawObject $ VisCylinder (cylinderHeight, cylinderRadius) (Xyz 0 0 0) (Quat 1 0 0 0) col
setMaterialDiffuse col 1
setColor col
translate (Vector3 0 0 cylinderHeight :: Vector3 GLdouble)
renderObject Solid (Cone coneRadius coneHeight numSlices numStacks)
drawObject (VisAxes (size, aspectRatio) (Xyz x0 y0 z0) (Quat q0 q1 q2 q3)) = preservingMatrix $ do
translate (Vector3 x0 y0 z0 :: Vector3 GLdouble)
rotate (2 * acos q0 *180/pi :: GLdouble) (Vector3 q1 q2 q3)
let xAxis = VisArrow (size, aspectRatio) (Xyz 0 0 0) (Xyz 1 0 0) (Rgb 1 0 0)
yAxis = VisArrow (size, aspectRatio) (Xyz 0 0 0) (Xyz 0 1 0) (Rgb 0 1 0)
zAxis = VisArrow (size, aspectRatio) (Xyz 0 0 0) (Xyz 0 0 1) (Rgb 0 0 1)
drawObjects [xAxis, yAxis, zAxis]
display :: MVar a -> MVar (Maybe SpecialKey) -> MVar Bool -> Camera -> (Maybe SpecialKey -> a -> IO ()) -> DisplayCallback
display stateMVar keyRef visReadyMVar camera userDrawFun = do
clear [ ColorBuffer, DepthBuffer ]
preservingMatrix $ do
x0 <- get (x0c camera)
y0 <- get (y0c camera)
z0 <- get (z0c camera)
phi' <- get (phi camera)
theta' <- get (theta camera)
rho' <- get (rho camera)
let
xc = x0 + rho'*cos(phi'*pi/180)*cos(theta'*pi/180)
yc = y0 + rho'*sin(phi'*pi/180)*cos(theta'*pi/180)
zc = z0 rho'*sin(theta'*pi/180)
lookAt (Vertex3 xc yc zc) (Vertex3 x0 y0 z0) (Vector3 0 0 (1))
state <- readMVar stateMVar
latestKey <- readMVar keyRef
userDrawFun latestKey state
flush
swapBuffers
_ <- swapMVar visReadyMVar True
postRedisplay Nothing
return ()
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 40 (fromIntegral w / fromIntegral h) 0.1 100
matrixMode $= Modelview 0
loadIdentity
postRedisplay Nothing
keyboardMouse :: Camera -> MVar (Maybe SpecialKey) -> KeyboardMouseCallback
keyboardMouse camera keyRef key keyState _ _ =
case (key, keyState) of
(Char '\27', Down) -> exitSuccess
(SpecialKey k, Down) -> do
_ <- swapMVar keyRef (Just k)
return ()
(SpecialKey _, Up) -> do
_ <- swapMVar keyRef Nothing
return ()
(MouseButton LeftButton, Down) -> do
resetMotion
leftButton camera $= 1
(MouseButton LeftButton, Up) -> leftButton camera $= 0
(MouseButton RightButton, Down) -> do
resetMotion
rightButton camera $= 1
(MouseButton RightButton, Up) -> rightButton camera $= 0
(MouseButton WheelUp, Down) -> zoom 0.9
(MouseButton WheelDown, Down) -> zoom 1.1
_ -> return ()
where resetMotion = do
ballX camera $= 1
ballY camera $= 1
zoom factor = do
rho camera $~ (* factor)
postRedisplay Nothing
motion :: Camera -> MotionCallback
motion camera (Position x y) = do
x0 <- get (x0c camera)
y0 <- get (y0c camera)
bx <- get (ballX camera)
by <- get (ballY camera)
phi' <- get (phi camera)
theta' <- get (theta camera)
rho' <- get (rho camera)
lb <- get (leftButton camera)
rb <- get (rightButton camera)
let deltaX
| bx == 1 = 0
| otherwise = fromIntegral (x bx)
deltaY
| by == 1 = 0
| otherwise = fromIntegral (y by)
nextTheta
| deltaY + theta' > 80 = 80
| deltaY + theta' < 80 = 80
| otherwise = deltaY + theta'
nextX0 = x0 + 0.003*rho'*( sin(phi'*pi/180)*deltaX cos(phi'*pi/180)*deltaY)
nextY0 = y0 + 0.003*rho'*( cos(phi'*pi/180)*deltaX sin(phi'*pi/180)*deltaY)
when (lb == 1) $ do
phi camera $~ (+ deltaX)
theta camera $= nextTheta
when (rb == 1) $ do
x0c camera $= nextX0
y0c camera $= nextY0
ballX camera $= x
ballY camera $= y
postRedisplay Nothing
vis :: Real b => Camera0 -> (Maybe SpecialKey -> a -> IO a) -> (Maybe SpecialKey -> a -> [VisObject b]) -> a -> Double -> IO ()
vis camera0 userSimFun userDrawFun x0 ts = do
(progName, _args) <- getArgsAndInitialize
myGlInit progName
stateMVar <- newMVar x0
camera <- makeCamera camera0
visReadyMVar <- newMVar False
latestKey <- newMVar Nothing
_ <- forkIO $ simThread stateMVar visReadyMVar userSimFun ts latestKey
displayCallback $= display stateMVar latestKey visReadyMVar camera (\x y -> drawObjects $ map (fmap realToFrac) (userDrawFun x y))
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboardMouse camera latestKey)
motionCallback $= Just (motion camera)
mainLoop
simThread :: MVar a -> MVar Bool -> (Maybe SpecialKey -> a -> IO a) -> Double -> MVar (Maybe SpecialKey) -> IO ()
simThread stateMVar visReadyMVar userSimFun ts keyRef = do
let waitUntilDisplayIsReady :: IO ()
waitUntilDisplayIsReady = do
visReady <- readMVar visReadyMVar
unless visReady $ do
threadDelay 10000
waitUntilDisplayIsReady
waitUntilDisplayIsReady
t0 <- getCurrentTime
lastTimeRef <- newIORef t0
forever $ do
currentTime <- getCurrentTime
lastTime <- get lastTimeRef
let usRemaining :: Int
usRemaining = round $ 1e6*(ts realToFrac (diffUTCTime currentTime lastTime))
if usRemaining <= 0
then do
lastTimeRef $= addUTCTime (realToFrac ts) lastTime
let getNextState = do
state <- readMVar stateMVar
latestKey <- readMVar keyRef
userSimFun latestKey state
let putState = swapMVar stateMVar
nextState <- getNextState
_ <- nextState `seq` putState nextState
postRedisplay Nothing
else threadDelay usRemaining