not-gloss 0.2.0 → 0.3.0
raw patch · 7 files changed
+378/−319 lines, 7 filesdep −not-gloss
Dependencies removed: not-gloss
Files
- Example.hs +0/−49
- Vis.hs +11/−6
- Vis/Camera.hs +80/−35
- Vis/Interface.hs +93/−212
- Vis/Vis.hs +183/−0
- Vis/VisObject.hs +9/−5
- not-gloss.cabal +2/−12
− Example.hs
@@ -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
Vis.hs view
@@ -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(..) )
Vis/Camera.hs view
@@ -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
Vis/Interface.hs view
@@ -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
+ Vis/Vis.hs view
@@ -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
Vis/VisObject.hs view
@@ -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
not-gloss.cabal view
@@ -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