diff --git a/Example.hs b/Example.hs new file mode 100644 --- /dev/null +++ b/Example.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -Wall #-} + +module Main where + +import Graphics.UI.GLUT( SpecialKey(..) ) +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,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 + 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) + +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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Greg Horn + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Greg Horn nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Vis.hs b/Vis.hs new file mode 100644 --- /dev/null +++ b/Vis.hs @@ -0,0 +1,419 @@ +-- Vis.hs + +{-# OPTIONS_GHC -Wall #-} + +module Vis ( vis + , VisObject(..) + , VisColor(..) + , Camera0(..) + ) where + +import Data.IORef ( newIORef ) +import System.Exit ( exitSuccess ) +import Graphics.UI.GLUT +import Data.Time.Clock +import Control.Concurrent +import Control.Monad +import Graphics.Rendering.OpenGL.Raw( glBegin, glEnd, gl_QUADS, gl_QUAD_STRIP, gl_TRIANGLES, glVertex3f, glVertex3d, glNormal3d, gl_TRIANGLE_FAN ) + +import SpatialMath +import Vis.Camera + +data VisColor = Rgb GLfloat GLfloat GLfloat + | Rgba GLfloat GLfloat GLfloat GLfloat + +setColor :: VisColor -> IO () +setColor (Rgb r g b) = color (Color3 r g b) +setColor (Rgba r g b a) = color (Color4 r g b a) + +setMaterialDiffuse :: VisColor -> GLfloat -> IO () +setMaterialDiffuse (Rgb r g b) a = materialDiffuse Front $= Color4 r g b a +setMaterialDiffuse (Rgba r g b a) _ = materialDiffuse Front $= Color4 r g b a + +data VisObject a = VisCylinder (a,a) (Xyz a) (Quat a) VisColor + | VisBox (a,a,a) (Xyz a) (Quat a) VisColor + | VisLine [Xyz a] VisColor + | VisArrow (a,a) (Xyz a) (Xyz a) VisColor + | VisAxes (a,a) (Xyz a) (Quat a) + | VisPlane (Xyz a) a VisColor VisColor + | VisTriangle (Xyz a) (Xyz a) (Xyz a) VisColor + | VisQuad (Xyz a) (Xyz a) (Xyz a) (Xyz a) VisColor + +instance Functor VisObject where + fmap f (VisCylinder (x,y) xyz quat col) = VisCylinder (f x, f y) (fmap f xyz) (fmap f quat) col + fmap f (VisBox (x,y,z) xyz quat col) = VisBox (f x, f y, f z) (fmap f xyz) (fmap f quat) col + fmap f (VisLine xyzs col) = VisLine (map (fmap f) xyzs) col + fmap f (VisArrow (x,y) xyz0 xyz1 col) = VisArrow (f x, f y) (fmap f xyz0) (fmap f xyz1) col + fmap f (VisAxes (x,y) xyz quat) = VisAxes (f x, f y) (fmap f xyz) (fmap f quat) + fmap f (VisPlane xyz x col0 col1) = VisPlane (fmap f xyz) (f x) col0 col1 + fmap f (VisTriangle x0 x1 x2 col) = VisTriangle (fmap f x0) (fmap f x1) (fmap f x2) col + fmap f (VisQuad x0 x1 x2 x3 col) = VisQuad (fmap f x0) (fmap f x1) (fmap f x2) (fmap f x3) col + +myGlInit :: String -> IO () +myGlInit progName = do + initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] + Size x y <- get screenSize + putStrLn $ "screen resolution " ++ show x ++ "x" ++ show y + let intScale d i = round $ d*(realToFrac i :: Double) + x0 = intScale 0.3 x + xf = intScale 0.95 x + y0 = intScale 0.05 y + yf = intScale 0.95 y + initialWindowSize $= Size (xf - x0) (yf - y0) + initialWindowPosition $= Position (fromIntegral x0) (fromIntegral y0) + _ <- createWindow progName + + clearColor $= Color4 0 0 0 0 + shadeModel $= Smooth + depthFunc $= Just Less + lighting $= Enabled + light (Light 0) $= Enabled + ambient (Light 0) $= Color4 1 1 1 1 + + materialDiffuse Front $= Color4 0.5 0.5 0.5 1 + materialSpecular Front $= Color4 1 1 1 1 + materialShininess Front $= 25 + colorMaterial $= Just (Front, Diffuse) + + +drawObjects :: [VisObject GLdouble] -> IO () +drawObjects = mapM_ drawObject + where + drawObject :: VisObject GLdouble -> IO () + + -- 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 + diff --git a/Vis/Camera.hs b/Vis/Camera.hs new file mode 100644 --- /dev/null +++ b/Vis/Camera.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -Wall #-} + +module Vis.Camera ( Camera0(..) + , Camera(..) + , makeCamera + ) where + +import Data.IORef ( IORef, newIORef ) +import Graphics.UI.GLUT ( GLdouble, GLint ) + +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 + } + +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' + } + diff --git a/not-gloss.cabal b/not-gloss.cabal new file mode 100644 --- /dev/null +++ b/not-gloss.cabal @@ -0,0 +1,39 @@ +name: not-gloss +version: 0.1.0 +synopsis: Painless 3D graphics, no affiliation with gloss +-- description: +license: BSD3 +license-file: LICENSE +author: Greg Horn +maintainer: gregmainland@gmail.com +-- copyright: +category: Graphics +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Vis + + other-modules: Vis.Camera + + build-depends: base == 4.5.*, + GLUT == 2.3.*, + time == 1.4.*, + OpenGLRaw == 1.2.*, + spatial-math >= 0.1.2 && < 0.2 + + 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.*, + not-gloss + ghc-options: -threaded + +source-repository head + type: git + location: git://github.com/ghorn/not-gloss.git