diff --git a/Example.hs b/Example.hs --- a/Example.hs +++ b/Example.hs @@ -2,9 +2,9 @@ module Main where -import Graphics.UI.GLUT( SpecialKey(..) ) import SpatialMath import qualified Quat + import Vis ts :: Double @@ -18,14 +18,26 @@ dq = Quat 1 (x*ts) (v*ts) (x*v*ts) drawFun :: Maybe SpecialKey -> State Double -> [VisObject Double] -drawFun key (State (x,_) quat) = [axes,box,plane] +drawFun key (State (x,_) quat) = [axes,box,ellipsoid,sphere] ++ (map text [-5..5]) ++ [boxText, plane] where axes = VisAxes (0.5, 15) (Xyz 0 0 0) (Quat 1 0 0 0) - box = VisBox (0.2, 0.2, 0.2) (Xyz 0 0 x) quat col + sphere = VisSphere 0.15 (Xyz 0 x (-1)) Wireframe col where - col = case key of Nothing -> Rgb 0 1 1 - _ -> Rgb 1 1 0 - plane = VisPlane (Xyz 0 0 1) 0 (Rgb 1 1 1) (Rgba 0.4 0.6 0.65 0.4) + col = case key of Nothing -> makeColor 0.2 0.3 0.8 1 + _ -> makeColor 0.2 0.3 0.8 0.4 + ellipsoid = VisEllipsoid (0.2, 0.3, 0.4) (Xyz x 0 (-1)) quat Solid col + where + col = case key of Nothing -> makeColor 1 0.3 0.5 1 + _ -> makeColor 1 0.3 0.5 0.3 + box = VisBox (0.2, 0.2, 0.2) (Xyz 0 0 x) quat Wireframe col + where + col = case key of Nothing -> makeColor 0 1 1 1 + _ -> makeColor 0 1 1 0.2 + plane = VisPlane (Xyz 0 0 1) 0 (makeColor 1 1 1 1) (makeColor 0.4 0.6 0.65 0.4) + text k = Vis2dText "OLOLOLOLOLO" (100,500 - k*100*x) TimesRoman24 (makeColor 0 (0.5 + x'/2) (0.5 - x'/2) 1) + where + x' = realToFrac $ (x + 1)/0.4*k/5 + boxText = Vis3dText "trololololo" (Xyz 0 0 (x-0.2)) TimesRoman24 (makeColor 1 0 0 1) main :: IO () main = do diff --git a/Vis.hs b/Vis.hs --- a/Vis.hs +++ b/Vis.hs @@ -1,419 +1,16 @@ --- Vis.hs - {-# OPTIONS_GHC -Wall #-} module Vis ( vis , VisObject(..) - , VisColor(..) , Camera0(..) + , SpecialKey(..) + , BitmapFont(..) + , Flavour(..) + , module Graphics.Gloss.Data.Color ) 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 () - - -- triangle - 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 - - -- quad - 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 - - -- cylinder - 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) ----- translate (Vector3 0 0 (-height/2) :: Vector3 GLdouble) - - let nslices = 10 :: Int - nstacks = 10 :: Int - - -- Pre-computed circle - sinCosTable = map (\q -> (sin q, cos q)) angles - where - angle = 2*pi/(fromIntegral nslices) - angles = reverse $ map ((angle*) . fromIntegral) [0..(nslices+1)] - - -- Cover the base and top - 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 -- Do the stacks - -- Step in z and radius as stacks are drawn. - 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) - - -- box - 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 - - -- line - 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 - - -- plane - 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 - - -- arrow - 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 - - -- cylinder - drawObject $ VisCylinder (cylinderHeight, cylinderRadius) (Xyz 0 0 0) (Quat 1 0 0 0) col - -- cone - 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 ] - - -- draw the scene - preservingMatrix $ do - -- setup the camera - 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)) - - -- call user function - state <- readMVar stateMVar - latestKey <- readMVar keyRef - userDrawFun latestKey state - - ---- draw the torus - --color (Color3 0 1 1 :: Color3 GLfloat) - --renderObject Solid (Torus 0.275 1.85 8 15) - - 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 - -- kill sim thread when main loop finishes - (Char '\27', Down) -> exitSuccess - - -- set keyRef - (SpecialKey k, Down) -> do - _ <- swapMVar keyRef (Just k) - return () - (SpecialKey _, Up) -> do - _ <- swapMVar keyRef Nothing - return () - - -- adjust camera - (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 - -- init glut/scene - (progName, _args) <- getArgsAndInitialize - myGlInit progName - - -- create internal state - stateMVar <- newMVar x0 - camera <- makeCamera camera0 - visReadyMVar <- newMVar False - latestKey <- newMVar Nothing - - -- start sim thread - _ <- forkIO $ simThread stateMVar visReadyMVar userSimFun ts latestKey - - -- setup callbacks - 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) - - -- start main loop - 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 - -- calculate how much longer to sleep before taking a timestep - currentTime <- getCurrentTime - lastTime <- get lastTimeRef - let usRemaining :: Int - usRemaining = round $ 1e6*(ts - realToFrac (diffUTCTime currentTime lastTime)) - - if usRemaining <= 0 - -- slept for long enough, do a sim iteration - 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 - - -- need to sleep longer - else threadDelay usRemaining - +import Vis.Interface +import Vis.VisObject +import Graphics.Gloss.Data.Color +import Graphics.UI.GLUT diff --git a/Vis/Camera.hs b/Vis/Camera.hs --- a/Vis/Camera.hs +++ b/Vis/Camera.hs @@ -48,4 +48,3 @@ , leftButton = leftButton' , rightButton = rightButton' } - diff --git a/Vis/Interface.hs b/Vis/Interface.hs new file mode 100644 --- /dev/null +++ b/Vis/Interface.hs @@ -0,0 +1,228 @@ +{-# OPTIONS_GHC -Wall #-} + +module Vis.Interface ( vis + ) where + +import Data.IORef ( newIORef ) +import System.Exit ( exitSuccess ) +import Data.Time.Clock ( getCurrentTime, diffUTCTime, addUTCTime ) +import Control.Concurrent ( MVar, readMVar, swapMVar, newMVar, forkIO, threadDelay ) +import Control.Monad ( when, unless, forever ) +import Graphics.UI.GLUT +import Graphics.Rendering.OpenGL.Raw + +import Vis.Camera ( Camera(..) , makeCamera, Camera0(..) ) +import Vis.VisObject ( VisObject(..), drawObjects, setPerspectiveMode ) + +myGlInit :: String -> IO () +myGlInit progName = do + initialDisplayMode $= [ DoubleBuffered, RGBAMode, 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 $= 100 + colorMaterial $= Just (Front, Diffuse) + + glEnable gl_BLEND + glBlendFunc gl_SRC_ALPHA gl_ONE_MINUS_SRC_ALPHA + +display :: MVar a -> MVar (Maybe SpecialKey) -> MVar Bool -> Camera -> (Maybe SpecialKey -> a -> IO ()) -> DisplayCallback +display stateMVar keyRef visReadyMVar camera userDrawFun = do + clear [ ColorBuffer, DepthBuffer ] + + -- draw the scene + preservingMatrix $ do + -- setup the camera + 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)) + + -- call user function + state <- readMVar stateMVar + latestKey <- readMVar keyRef + userDrawFun latestKey state + + ---- draw the torus + --color (Color3 0 1 1 :: Color3 GLfloat) + --renderObject Solid (Torus 0.275 1.85 8 15) + + flush + swapBuffers + _ <- swapMVar visReadyMVar True + postRedisplay Nothing + return () + + +reshape :: ReshapeCallback +reshape size@(Size _ _) = do + viewport $= (Position 0 0, size) + setPerspectiveMode + loadIdentity + postRedisplay Nothing + +keyboardMouse :: Camera -> MVar (Maybe SpecialKey) -> KeyboardMouseCallback +keyboardMouse camera keyRef key keyState _ _ = + case (key, keyState) of + -- kill sim thread when main loop finishes + (Char '\27', Down) -> exitSuccess + + -- set keyRef + (SpecialKey k, Down) -> do + _ <- swapMVar keyRef (Just k) + return () + (SpecialKey _, Up) -> do + _ <- swapMVar keyRef Nothing + return () + + -- adjust camera + (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 + -- init glut/scene + (progName, _args) <- getArgsAndInitialize + myGlInit progName + + -- create internal state + stateMVar <- newMVar x0 + camera <- makeCamera camera0 + visReadyMVar <- newMVar False + latestKey <- newMVar Nothing + + -- start sim thread + _ <- forkIO $ simThread stateMVar visReadyMVar userSimFun ts latestKey + + -- setup callbacks + 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) + + -- start main loop + 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 + -- calculate how much longer to sleep before taking a timestep + currentTime <- getCurrentTime + lastTime <- get lastTimeRef + let usRemaining :: Int + usRemaining = round $ 1e6*(ts - realToFrac (diffUTCTime currentTime lastTime)) + + if usRemaining <= 0 + -- slept for long enough, do a sim iteration + 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 + + -- need to sleep longer + else threadDelay usRemaining + diff --git a/Vis/VisObject.hs b/Vis/VisObject.hs new file mode 100644 --- /dev/null +++ b/Vis/VisObject.hs @@ -0,0 +1,263 @@ +{-# OPTIONS_GHC -Wall #-} + +module Vis.VisObject ( VisObject(..) + , drawObjects + , setPerspectiveMode + ) where + +import Graphics.Rendering.OpenGL.Raw +import qualified Graphics.Gloss.Data.Color as Gloss +import Graphics.UI.GLUT + +import SpatialMath + +glColorOfColor :: Gloss.Color -> Color4 GLfloat +glColorOfColor = (\(r,g,b,a) -> fmap realToFrac (Color4 r g b a)) . Gloss.rgbaOfColor + +setColor :: Gloss.Color -> IO () +setColor = color . glColorOfColor + +setMaterialDiffuse :: Gloss.Color -> IO () +setMaterialDiffuse col = materialDiffuse Front $= (glColorOfColor col) + +data VisObject a = VisCylinder (a,a) (Xyz a) (Quat a) Gloss.Color + | VisBox (a,a,a) (Xyz a) (Quat a) Flavour Gloss.Color + | VisEllipsoid (a,a,a) (Xyz a) (Quat a) Flavour Gloss.Color + | VisSphere a (Xyz a) Flavour Gloss.Color + | VisLine [Xyz a] Gloss.Color + | VisArrow (a,a) (Xyz a) (Xyz a) Gloss.Color + | VisAxes (a,a) (Xyz a) (Quat a) + | VisPlane (Xyz a) a Gloss.Color Gloss.Color + | VisTriangle (Xyz a) (Xyz a) (Xyz a) Gloss.Color + | VisQuad (Xyz a) (Xyz a) (Xyz a) (Xyz a) Gloss.Color + | VisCustom (IO ()) + | Vis3dText String (Xyz a) BitmapFont Gloss.Color + | Vis2dText String (a,a) BitmapFont Gloss.Color + +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 flav col) = VisBox (f x, f y, f z) (fmap f xyz) (fmap f quat) flav col + fmap f (VisSphere s xyz flav col) = VisSphere (f s) (fmap f xyz) flav col + fmap f (VisEllipsoid (sx,sy,sz) xyz quat flav col) = VisEllipsoid (f sx, f sy, f sz) (fmap f xyz) (fmap f quat) flav 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 + fmap f (Vis3dText t xyz bmf col) = Vis3dText t (fmap f xyz) bmf col + fmap f (Vis2dText t (x,y) bmf col) = Vis2dText t (f x, f y) bmf col + fmap _ (VisCustom f) = VisCustom f + +setPerspectiveMode :: IO () +setPerspectiveMode = do + (_, Size w h) <- get viewport + matrixMode $= Projection + loadIdentity + perspective 40 (fromIntegral w / fromIntegral h) 0.1 100 + matrixMode $= Modelview 0 + + +drawObjects :: [VisObject GLdouble] -> IO () +drawObjects objects = do + setPerspectiveMode + mapM_ drawObject objects + +drawObject :: VisObject GLdouble -> IO () +-- triangle +drawObject (VisTriangle (Xyz x0 y0 z0) (Xyz x1 y1 z1) (Xyz x2 y2 z2) col) = + preservingMatrix $ do + setMaterialDiffuse col + setColor col + glBegin gl_TRIANGLES + glVertex3d x0 y0 z0 + glVertex3d x1 y1 z1 + glVertex3d x2 y2 z2 + glEnd + +-- quad +drawObject (VisQuad (Xyz x0 y0 z0) (Xyz x1 y1 z1) (Xyz x2 y2 z2) (Xyz x3 y3 z3) col) = + preservingMatrix $ do + setMaterialDiffuse col + setColor col + glBegin gl_QUADS + glVertex3d x0 y0 z0 + glVertex3d x1 y1 z1 + glVertex3d x2 y2 z2 + glVertex3d x3 y3 z3 + glEnd + +-- cylinder +drawObject (VisCylinder (height,radius) (Xyz x y z) (Quat q0 q1 q2 q3) col) = + preservingMatrix $ do + setMaterialDiffuse col + setColor col + + translate (Vector3 x y z :: Vector3 GLdouble) + rotate (2 * acos q0 *180/pi :: GLdouble) (Vector3 q1 q2 q3) + -- translate (Vector3 0 0 (-height/2) :: Vector3 GLdouble) + + let nslices = 10 :: Int + nstacks = 10 :: Int + + -- Pre-computed circle + sinCosTable = map (\q -> (sin q, cos q)) angles + where + angle = 2*pi/(fromIntegral nslices) + angles = reverse $ map ((angle*) . fromIntegral) [0..(nslices+1)] + + -- Cover the base and top + 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 -- Do the stacks + -- Step in z and radius as stacks are drawn. + 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) + +-- sphere +drawObject (VisSphere s xyz flav col) = drawObject $ VisEllipsoid (s,s,s) xyz (Quat 1 0 0 0) flav col + +-- ellipsoid +drawObject (VisEllipsoid (sx,sy,sz) (Xyz x y z) (Quat q0 q1 q2 q3) flav col) = + preservingMatrix $ do + setMaterialDiffuse col + setColor col + translate (Vector3 x y z :: Vector3 GLdouble) + rotate (2 * acos q0 *180/pi :: GLdouble) (Vector3 q1 q2 q3) + normalize $= Enabled + scale sx sy sz + renderObject flav (Sphere' 1 20 20) + normalize $= Disabled + +-- box +drawObject (VisBox (dx,dy,dz) (Xyz x y z) (Quat q0 q1 q2 q3) flav col) = + preservingMatrix $ do + setMaterialDiffuse col + 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 flav (Cube 1) + normalize $= Disabled + +-- line +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 + +-- plane +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) + + 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 + + glDisable gl_BLEND + 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]] + glEnable gl_BLEND + + +-- arrow +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 + + -- cylinder + drawObject $ VisCylinder (cylinderHeight, cylinderRadius) (Xyz 0 0 0) (Quat 1 0 0 0) col + -- cone + setMaterialDiffuse col + 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) (Gloss.makeColor 1 0 0 1) + yAxis = VisArrow (size, aspectRatio) (Xyz 0 0 0) (Xyz 0 1 0) (Gloss.makeColor 0 1 0 1) + zAxis = VisArrow (size, aspectRatio) (Xyz 0 0 0) (Xyz 0 0 1) (Gloss.makeColor 0 0 1 1) + drawObjects [xAxis, yAxis, zAxis] + +drawObject (VisCustom f) = preservingMatrix f + +drawObject (Vis3dText string (Xyz x y z) font col) = preservingMatrix $ do + lighting $= Disabled + setColor col + glRasterPos3d x y z + renderString font string + lighting $= Enabled + +drawObject (Vis2dText string (x,y) font col) = preservingMatrix $ do + lighting $= Disabled + setColor col + + matrixMode $= Projection + loadIdentity + + (_, Size w h) <- get viewport + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + matrixMode $= Modelview 0 + loadIdentity + + glRasterPos2d x y + renderString font string + + setPerspectiveMode + lighting $= Enabled diff --git a/not-gloss.cabal b/not-gloss.cabal --- a/not-gloss.cabal +++ b/not-gloss.cabal @@ -1,7 +1,15 @@ name: not-gloss -version: 0.1.0 +version: 0.2.0 +stability: Experimental synopsis: Painless 3D graphics, no affiliation with gloss --- description: +description:{ +This package intends to make it relatively easy to do simple 3d graphics using high-level primitives. +It is inspired by gloss and attempts to emulate it. +This is an early release and the api will certainly change. +Note that transparency can be controlled by the alpha value: "makeColor r g b alpha" but that you must draw objects from back to front for transparency to properly work (just put clear things last). +Also, transparent ellipsoids and cylinders have ugly artifacts, sorry. +Look at the example `Example.hs` to get started. +} license: BSD3 license-file: LICENSE author: Greg Horn @@ -13,14 +21,18 @@ library exposed-modules: Vis + Vis.Camera + Vis.Interface + Vis.VisObject - other-modules: Vis.Camera + other-modules: build-depends: base == 4.5.*, GLUT == 2.3.*, time == 1.4.*, OpenGLRaw == 1.2.*, - spatial-math >= 0.1.2 && < 0.2 + spatial-math >= 0.1.2 && < 0.2, + gloss >= 1.7.4 && < 1.7.5 ghc-options: @@ -31,6 +43,7 @@ spatial-math >= 0.1.2 && < 0.2, OpenGLRaw == 1.2.*, time == 1.4.*, + gloss >= 1.7.4 && < 1.7.5, not-gloss ghc-options: -threaded