not-gloss 0.1.0 → 0.2.0

raw patch · 6 files changed

+534/−422 lines, 6 filesdep +glossPVP ok

version bump matches the API change (PVP)

Dependencies added: gloss

API changes (from Hackage documentation)

Files

• Example.hs +18/−6
• Vis.hs +8/−411
• Vis/Camera.hs +0/−1
• Vis/Interface.hs +228/−0
• Vis/VisObject.hs +263/−0
• not-gloss.cabal +17/−4

@@ -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

@@ -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

@@ -48,4 +48,3 @@                 , leftButton = leftButton'                 , rightButton = rightButton'                 }-

@@ -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+           

@@ -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

@@ -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