diff --git a/Example.hs b/Example.hs deleted file mode 100644 --- a/Example.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} - -module Main where - -import SpatialMath -import qualified Quat - -import Vis - -ts :: Double -ts = 0.01 - -data State a = State (a,a) (Quat a) - -simloop :: Maybe SpecialKey -> State Double -> IO (State Double) -simloop _ (State (x,v) q0) = return $ State (x + v*ts, v + 5*ts*(-1 - x)) (Quat.qmult' q0 dq) - where - dq = Quat 1 (x*ts) (v*ts) (x*v*ts) - -drawFun :: Maybe SpecialKey -> State Double -> [VisObject Double] -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) - sphere = VisSphere 0.15 (Xyz 0 x (-1)) Wireframe col - where - 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 - putStrLn "press arrow keys to change color" - let camera0 = Camera0 { phi0 = 60 - , theta0 = 20 - , rho0 = 7} - state0 = State (-1.4,0) (Quat 1 0 0 0) - vis camera0 simloop drawFun state0 ts diff --git a/Vis.hs b/Vis.hs --- a/Vis.hs +++ b/Vis.hs @@ -1,16 +1,21 @@ {-# OPTIONS_GHC -Wall #-} -module Vis ( vis +module Vis ( display + , animate + , simulate + , play + , animateIO + , simulateIO + , playIO , VisObject(..) - , Camera0(..) , SpecialKey(..) , BitmapFont(..) , Flavour(..) , module Graphics.Gloss.Data.Color ) where -import Vis.Camera -import Vis.Interface -import Vis.VisObject import Graphics.Gloss.Data.Color -import Graphics.UI.GLUT +import Graphics.UI.GLUT ( SpecialKey(..), BitmapFont(..), Flavour(..) ) + +import Vis.Interface ( display, animate, simulate, play, animateIO, simulateIO, playIO ) +import Vis.VisObject ( VisObject(..) ) diff --git a/Vis/Camera.hs b/Vis/Camera.hs --- a/Vis/Camera.hs +++ b/Vis/Camera.hs @@ -3,48 +3,93 @@ module Vis.Camera ( Camera0(..) , Camera(..) , makeCamera + , setCamera + , cameraMotion + , cameraKeyboardMouse ) where -import Data.IORef ( IORef, newIORef ) -import Graphics.UI.GLUT ( GLdouble, GLint ) +import Xyz +import Graphics.UI.GLUT data Camera0 = Camera0 { phi0 :: GLdouble , theta0 :: GLdouble , rho0 :: GLdouble } -data Camera = Camera { phi :: IORef GLdouble - , theta :: IORef GLdouble - , rho :: IORef GLdouble - , x0c :: IORef GLdouble - , y0c :: IORef GLdouble - , z0c :: IORef GLdouble - , ballX :: IORef GLint - , ballY :: IORef GLint - , leftButton :: IORef GLint - , rightButton :: IORef GLint +data Camera = Camera { phi :: GLdouble + , theta :: GLdouble + , rho :: GLdouble + , pos :: Xyz GLdouble + , ballX :: GLint + , ballY :: GLint + , leftButton :: GLint + , rightButton :: GLint } -makeCamera :: Camera0 -> IO Camera -makeCamera camera0 = do - phi' <- newIORef $ phi0 camera0 - theta' <- newIORef $ theta0 camera0 - rho' <- newIORef $ rho0 camera0 - x0 <- newIORef 0 - y0 <- newIORef 0 - z0 <- newIORef 0 - ballX' <- newIORef (-1) - ballY' <- newIORef (-1) - leftButton' <- newIORef 0 - rightButton' <- newIORef 0 - return Camera { phi = phi' - , theta = theta' - , rho = rho' - , x0c = x0 - , y0c = y0 - , z0c = z0 - , ballX = ballX' - , ballY = ballY' - , leftButton = leftButton' - , rightButton = rightButton' - } +makeCamera :: Camera0 -> Camera +makeCamera camera0 = Camera { phi = phi0 camera0 + , theta = theta0 camera0 + , rho = rho0 camera0 + , pos = Xyz 0 0 0 + , ballX = (-1) + , ballY = (-1) + , leftButton = 0 + , rightButton = 0 + } + +setCamera :: Camera -> IO () +setCamera camera = lookAt (Vertex3 xc yc zc) (Vertex3 x0 y0 z0) (Vector3 0 0 (-1)) + where + Xyz x0 y0 z0 = pos camera + phi' = phi camera + theta' = theta camera + rho' = rho camera + + 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) + +cameraMotion :: Camera -> Position -> Camera +cameraMotion (Camera phi0' theta0' rho0' (Xyz x0 y0 z0) bx by lb rb) (Position x y) = + Camera nextPhi nextTheta rho0' nextPos nextBallX nextBallY lb rb + where + deltaX + | bx == -1 = 0 + | otherwise = fromIntegral (x - bx) + deltaY + | by == -1 = 0 + | otherwise = fromIntegral (y - by) + nextTheta' + | deltaY + theta0' > 80 = 80 + | deltaY + theta0' < -80 = -80 + | otherwise = deltaY + theta0' + nextX = x0 + 0.003*rho0'*( -sin(phi0'*pi/180)*deltaX - cos(phi0'*pi/180)*deltaY) + nextY = y0 + 0.003*rho0'*( cos(phi0'*pi/180)*deltaX - sin(phi0'*pi/180)*deltaY) + + (nextPhi, nextTheta) = if lb == 1 + then (phi0' + deltaX, nextTheta') + else (phi0', theta0') + + nextPos = if rb == 1 + then Xyz nextX nextY z0 + else Xyz x0 y0 z0 + + nextBallX = x + nextBallY = y + +cameraKeyboardMouse :: Camera -> Key -> KeyState -> Camera +cameraKeyboardMouse camera key keyState = + camera {rho = newRho, leftButton = lb, rightButton = rb, ballX = bx, ballY = by} + where + (lb, reset0) = case (key, keyState) of (MouseButton LeftButton, Down) -> (1, True) + (MouseButton LeftButton, Up) -> (0, False) + _ -> (leftButton camera, False) + (rb, reset1) = case (key, keyState) of (MouseButton RightButton, Down) -> (1, True) + (MouseButton RightButton, Up) -> (0, False) + _ -> (rightButton camera, False) + + (bx,by) = if reset0 || reset1 then (-1,-1) else (ballX camera, ballY camera) + + newRho = case (key, keyState) of (MouseButton WheelUp, Down) -> 0.9 * (rho camera) + (MouseButton WheelDown, Down) -> 1.1 * (rho camera) + _ -> rho camera diff --git a/Vis/Interface.hs b/Vis/Interface.hs --- a/Vis/Interface.hs +++ b/Vis/Interface.hs @@ -1,228 +1,109 @@ {-# OPTIONS_GHC -Wall #-} -module Vis.Interface ( vis +module Vis.Interface ( display + , animate + , animateIO + , simulate + , simulateIO + , play + , playIO ) 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 ) +import Graphics.UI.GLUT ( Key, KeyState, Position, Modifiers ) -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 +import Vis.Vis ( vis ) +import Vis.Camera ( makeCamera, Camera0(..), setCamera, cameraMotion, cameraKeyboardMouse ) +import Vis.VisObject ( VisObject(..) ) - 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 +-- | draw a static image +display :: Real b => VisObject b -> IO () +display visobjects = animate (\_ -> visobjects) -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 +-- | display an animation +animate :: Real b => (Float -> VisObject b) -> IO () +animate userDrawFun = animateIO (return . userDrawFun) - ---- 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 () +-- | display an animation impurely +animateIO :: Real b => (Float -> IO (VisObject b)) -> IO () +animateIO userDrawFun = + vis ts (userState0, cameraState0) simFun drawFun setCameraFun (Just kmCallback) (Just motionCallback) Nothing + where + ts = 0.01 + userState0 = () + cameraState0 = makeCamera $ Camera0 { phi0 = 60 + , theta0 = 20 + , rho0 = 7} + drawFun (_,time) = userDrawFun time + simFun (state,_) = return state + kmCallback (state, camState) k0 k1 _ _ = (state, cameraKeyboardMouse camState k0 k1) + motionCallback (state, cameraState) pos = (state, cameraMotion cameraState pos) + setCameraFun (_,cameraState) = setCamera cameraState -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 - +-- | run a simulation +simulate :: Real b => + Double -- ^ sample rate + -> world -- ^ initial state + -> (world -> VisObject b) -- ^ draw function + -> (Float -> world -> world) -- ^ state propogation function (takes current time and state as inputs) + -> IO () +simulate ts state0 userDrawFun userSimFun = + simulateIO ts state0 (return . userDrawFun) (\t -> return . (userSimFun t)) -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 +-- | run a simulation impurely +simulateIO :: Real b => + Double -- ^ sample rate + -> world -- ^ initial state + -> (world -> IO (VisObject b)) -- ^ draw function + -> (Float -> world -> IO world) -- ^ state propogation function (takes current time and state as inputs) + -> IO () +simulateIO ts userState0 userDrawFun userSimFun = + vis ts (userState0, cameraState0) simFun drawFun setCameraFun (Just kmCallback) (Just motionCallback) Nothing + where + drawFun ((userState, _),_) = userDrawFun userState + simFun ((userState,cameraState),time) = do + nextUserState <- userSimFun time userState + return (nextUserState, cameraState) + cameraState0 = makeCamera $ Camera0 { phi0 = 60 + , theta0 = 20 + , rho0 = 7} + kmCallback (state, camState) k0 k1 _ _ = (state, cameraKeyboardMouse camState k0 k1) + motionCallback (state, cameraState) pos = (state, cameraMotion cameraState pos) + setCameraFun (_,cameraState) = setCamera cameraState -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 +---- | play a game +play :: Real b => + Double -- ^ sample time + -> world -- ^ initial state + -> (world -> (VisObject b)) -- ^ draw function + -> (Float -> world -> world) -- ^ state propogation function (takes current time and state as inputs) + -> (world -> IO ()) -- ^ set where camera looks + -> Maybe (world -> Key -> KeyState -> Modifiers -> Position -> world) -- ^ keyboard/mouse press callback + -> Maybe (world -> Position -> world) -- ^ mouse drag callback + -> Maybe (world -> Position -> world) -- ^ mouse move callback + -> IO () +play ts userState0 userDrawFun userSimFun = + vis ts userState0 simFun drawFun + where + drawFun (userState, _) = return $ userDrawFun userState + simFun (userState,time) = return $ userSimFun time userState -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 - +---- | play a game impurely +playIO :: Real b => + Double -- ^ sample time + -> world -- ^ initial state + -> (world -> IO (VisObject b)) -- ^ draw function + -> (Float -> world -> IO world) -- ^ state propogation function (takes current time and state as inputs) + -> (world -> IO ()) -- ^ set where camera looks + -> Maybe (world -> Key -> KeyState -> Modifiers -> Position -> world) -- ^ keyboard/mouse press callback + -> Maybe (world -> Position -> world) -- ^ mouse drag callback + -> Maybe (world -> Position -> world) -- ^ mouse move callback + -> IO () +playIO ts userState0 userDrawFun userSimFun = + vis ts userState0 simFun drawFun + where + drawFun (userState, _) = userDrawFun userState + simFun (userState,time) = userSimFun time userState diff --git a/Vis/Vis.hs b/Vis/Vis.hs new file mode 100644 --- /dev/null +++ b/Vis/Vis.hs @@ -0,0 +1,183 @@ +{-# OPTIONS_GHC -Wall #-} + +module Vis.Vis ( vis + , FullState + ) 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 ( unless, forever ) +import Graphics.UI.GLUT +import Graphics.Rendering.OpenGL.Raw + +import Vis.VisObject ( VisObject(..), drawObjects, setPerspectiveMode ) + +-- user state and internal states +type FullState a = (a, Float) + +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 + +drawScene :: MVar (FullState a) -> MVar Bool -> IO () -> (FullState a -> IO ()) -> DisplayCallback +drawScene stateMVar visReadyMVar setCameraFun userDrawFun = do + clear [ ColorBuffer, DepthBuffer ] + + -- draw the scene + preservingMatrix $ do + -- set the camera's position and orientation + setCameraFun + + -- call user function + state <- readMVar stateMVar + userDrawFun state + + flush + swapBuffers + _ <- swapMVar visReadyMVar True + postRedisplay Nothing + + +reshape :: ReshapeCallback +reshape size@(Size _ _) = do + viewport $= (Position 0 0, size) + setPerspectiveMode + loadIdentity + postRedisplay Nothing + + +vis :: Real b => + Double -- ^ sample time + -> a -- ^ initial state + -> (FullState a -> IO a) -- ^ sim function + -> (FullState a -> IO (VisObject b)) -- ^ draw function + -> (a -> IO ()) -- ^ set camera function + -> Maybe (a -> Key -> KeyState -> Modifiers -> Position -> a) -- ^ keyboard/mouse callback + -> Maybe (a -> Position -> a) -- ^ motion callback + -> Maybe (a -> Position -> a) -- ^ passive motion callback + -> IO () +vis ts x0 userSimFun userDraw userSetCamera userKeyMouseCallback userMotionCallback userPassiveMotionCallback = do + -- init glut/scene + (progName, _args) <- getArgsAndInitialize + myGlInit progName + + -- create internal state + let fullState0 = (x0, 0) + stateMVar <- newMVar fullState0 + visReadyMVar <- newMVar False + + -- start sim thread + _ <- forkIO $ simThread stateMVar visReadyMVar userSimFun ts + + -- setup the callbacks + let makePictures x = do + visobs <- userDraw x + drawObjects $ (fmap realToFrac) visobs + + setCamera = do + (state,_) <- readMVar stateMVar + userSetCamera state + + -- kill sim thread when someone hits ESC + exitOverride k0 k1 k2 k3 = case (k0,k1) of + (Char '\27', Down) -> exitSuccess + _ -> case userKeyMouseCallback of + Nothing -> return () + Just cb -> do + (state0',time) <- readMVar stateMVar + let state1 = cb state0' k0 k1 k2 k3 + _ <- state1 `seq` swapMVar stateMVar (state1, time) + postRedisplay Nothing + + motionCallback' pos = case userMotionCallback of + Nothing -> return () + Just cb -> do + (state0',ts') <- readMVar stateMVar + let state1 = cb state0' pos + _ <- state1 `seq` swapMVar stateMVar (state1,ts') + postRedisplay Nothing + + passiveMotionCallback' pos = case userPassiveMotionCallback of + Nothing -> return () + Just cb -> do + (state0',ts') <- readMVar stateMVar + let state1 = cb state0' pos + _ <- state1 `seq` swapMVar stateMVar (state1,ts') + postRedisplay Nothing + + displayCallback $= drawScene stateMVar visReadyMVar setCamera makePictures + reshapeCallback $= Just reshape + keyboardMouseCallback $= Just exitOverride + motionCallback $= Just motionCallback' + passiveMotionCallback $= Just passiveMotionCallback' + + -- start main loop + mainLoop + + +simThread :: MVar (FullState a) -> MVar Bool -> (FullState a -> IO a) -> Double -> IO () +simThread stateMVar visReadyMVar userSimFun ts = 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)) + secondsSinceStart = realToFrac (diffUTCTime currentTime t0) + + if usRemaining <= 0 + -- slept for long enough, do a sim iteration + then do + lastTimeRef $= addUTCTime (realToFrac ts) lastTime + + let getNextState = do + state <- readMVar stateMVar + userSimFun state + putState x = swapMVar stateMVar (x, secondsSinceStart) + + 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 --- a/Vis/VisObject.hs +++ b/Vis/VisObject.hs @@ -20,7 +20,8 @@ setMaterialDiffuse :: Gloss.Color -> IO () setMaterialDiffuse col = materialDiffuse Front $= (glColorOfColor col) -data VisObject a = VisCylinder (a,a) (Xyz a) (Quat a) Gloss.Color +data VisObject a = VisObjects [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 @@ -35,6 +36,7 @@ | Vis2dText String (a,a) BitmapFont Gloss.Color instance Functor VisObject where + fmap f (VisObjects xs) = VisObjects $ map (fmap f) xs 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 @@ -57,13 +59,15 @@ perspective 40 (fromIntegral w / fromIntegral h) 0.1 100 matrixMode $= Modelview 0 - -drawObjects :: [VisObject GLdouble] -> IO () +drawObjects :: VisObject GLdouble -> IO () drawObjects objects = do setPerspectiveMode - mapM_ drawObject objects + drawObject objects drawObject :: VisObject GLdouble -> IO () +-- list of objects +drawObject (VisObjects xs) = mapM_ drawObject xs + -- triangle drawObject (VisTriangle (Xyz x0 y0 z0) (Xyz x1 y1 z1) (Xyz x2 y2 z2) col) = preservingMatrix $ do @@ -233,7 +237,7 @@ 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 $ VisObjects [xAxis, yAxis, zAxis] drawObject (VisCustom f) = preservingMatrix f diff --git a/not-gloss.cabal b/not-gloss.cabal --- a/not-gloss.cabal +++ b/not-gloss.cabal @@ -1,5 +1,5 @@ name: not-gloss -version: 0.2.0 +version: 0.3.0 stability: Experimental synopsis: Painless 3D graphics, no affiliation with gloss description:{ @@ -23,6 +23,7 @@ exposed-modules: Vis Vis.Camera Vis.Interface + Vis.Vis Vis.VisObject other-modules: @@ -35,17 +36,6 @@ gloss >= 1.7.4 && < 1.7.5 ghc-options: - -executable not-gloss-example - main-is: Example.hs - build-depends: base == 4.5.*, - GLUT == 2.3.*, - 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 source-repository head type: git