diff --git a/Vis/Interface.hs b/Vis/Interface.hs --- a/Vis/Interface.hs +++ b/Vis/Interface.hs @@ -17,17 +17,29 @@ -- | draw a static image -display :: Real b => VisObject b -> IO () -display visobjects = animate (\_ -> visobjects) +display :: Real b => + Maybe ((Int,Int),(Int,Int)) -- ^ optional (window size, window position) + -> String -- ^ window name + -> VisObject b -- ^ object to draw + -> IO () +display sizepos name visobjects = animate sizepos name (\_ -> visobjects) --- | display an animation -animate :: Real b => (Float -> VisObject b) -> IO () -animate userDrawFun = animateIO (return . userDrawFun) +---- | display an animation +animate :: Real b => + Maybe ((Int,Int),(Int,Int)) -- ^ optional (window size, window position) + -> String -- ^ window name + -> (Float -> VisObject b) -- ^ draw function + -> IO () +animate sizepos name userDrawFun = animateIO sizepos name (return . userDrawFun) -- | 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 +animateIO :: Real b => + Maybe ((Int,Int),(Int,Int)) -- ^ optional (window size, window position) + -> String -- ^ window name + -> (Float -> IO (VisObject b)) -- ^ draw function + -> IO () +animateIO sizepos name userDrawFun = + vis sizepos name ts (userState0, cameraState0) simFun drawFun setCameraFun (Just kmCallback) (Just motionCallback) Nothing where ts = 0.01 userState0 = () @@ -45,23 +57,27 @@ -- | run a simulation simulate :: Real b => - Double -- ^ sample rate + Maybe ((Int,Int),(Int,Int)) -- ^ optional (window size, window position) + -> String -- ^ window name + -> 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)) +simulate sizepos name ts state0 userDrawFun userSimFun = + simulateIO sizepos name ts state0 (return . userDrawFun) (\t -> return . (userSimFun t)) -- | run a simulation impurely simulateIO :: Real b => - Double -- ^ sample rate + Maybe ((Int,Int),(Int,Int)) -- ^ optional (window size, window position) + -> String -- ^ window name + -> 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 +simulateIO sizepos name ts userState0 userDrawFun userSimFun = + vis sizepos name ts (userState0, cameraState0) simFun drawFun setCameraFun (Just kmCallback) (Just motionCallback) Nothing where drawFun ((userState, _),_) = do obs <- userDrawFun userState @@ -80,7 +96,9 @@ ---- | play a game play :: Real b => - Double -- ^ sample time + Maybe ((Int,Int),(Int,Int)) -- ^ optional (window size, window position) + -> String -- ^ window name + -> Double -- ^ sample time -> world -- ^ initial state -> (world -> (VisObject b, Maybe Cursor)) -- ^ draw function, can give a different cursor -> (Float -> world -> world) -- ^ state propogation function (takes current time and state as inputs) @@ -89,8 +107,8 @@ -> 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 +play sizepos name ts userState0 userDrawFun userSimFun = + vis sizepos name ts userState0 simFun drawFun where drawFun (userState, _) = return $ userDrawFun userState simFun (userState,time) = return $ userSimFun time userState @@ -98,7 +116,9 @@ ---- | play a game impurely playIO :: Real b => - Double -- ^ sample time + Maybe ((Int,Int),(Int,Int)) -- ^ optional (window size, window position) + -> String -- ^ window name + -> Double -- ^ sample time -> world -- ^ initial state -> (world -> IO (VisObject b, Maybe Cursor)) -- ^ draw function, can give a different cursor -> (Float -> world -> IO world) -- ^ state propogation function (takes current time and state as inputs) @@ -107,8 +127,8 @@ -> 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 +playIO sizepos name ts userState0 userDrawFun userSimFun = + vis sizepos name 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 --- a/Vis/Vis.hs +++ b/Vis/Vis.hs @@ -4,6 +4,7 @@ , FullState ) where +import Data.Maybe ( fromMaybe ) import Data.IORef ( newIORef ) import System.Exit ( exitSuccess ) import Data.Time.Clock ( getCurrentTime, diffUTCTime, addUTCTime ) @@ -17,20 +18,22 @@ -- user state and internal states type FullState a = (a, Float) -myGlInit :: String -> IO () -myGlInit progName = do +myGlInit :: Maybe ((Int,Int), (Int,Int)) -> String -> IO () +myGlInit sizepos progName = do initialDisplayMode $= [ DoubleBuffered, RGBAMode, WithDepthBuffer ] --- Size x y <- get screenSize - let x = 1600 :: Int - y = 1080 :: Int + + Size x y <- get screenSize putStrLn $ "screen resolution " ++ show x ++ "x" ++ show y let intScale d i = round $ d*(realToFrac i :: Double) - x0 = 1400 + intScale 0.3 x - xf = 1400 + intScale 0.95 x + 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) + + ((xsize,ysize),(xpos,ypos)) = fromMaybe ((xf-x0,yf-y0), (x0,y0)) sizepos + + initialWindowSize $= Size (fromIntegral xsize) (fromIntegral ysize) + initialWindowPosition $= Position (fromIntegral xpos) (fromIntegral ypos) _ <- createWindow progName clearColor $= Color4 0 0 0 0 @@ -76,7 +79,9 @@ vis :: Real b => - Double -- ^ sample time + Maybe ((Int,Int),(Int,Int)) -- ^ optional (window size, window position) + -> String -- ^ window name + -> Double -- ^ sample time -> a -- ^ initial state -> (FullState a -> IO a) -- ^ sim function -> (FullState a -> IO (VisObject b, Maybe Cursor)) -- ^ draw function, can give a different cursor @@ -85,12 +90,12 @@ -> Maybe (a -> Position -> a) -- ^ motion callback -> Maybe (a -> Position -> a) -- ^ passive motion callback -> IO () -vis ts x0 userSimFun userDraw userSetCamera +vis sizepos windowname ts x0 userSimFun userDraw userSetCamera userKeyMouseCallback userMotionCallback userPassiveMotionCallback = do -- init glut/scene - (progName, _) <- getArgsAndInitialize + _ <- getArgsAndInitialize - myGlInit progName + myGlInit sizepos windowname -- create internal state let fullState0 = (x0, 0) diff --git a/Vis/VisObject.hs b/Vis/VisObject.hs --- a/Vis/VisObject.hs +++ b/Vis/VisObject.hs @@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Wall #-} +{-# Language StandaloneDeriving #-} +{-# Language DeriveFunctor #-} module Vis.VisObject ( VisObject(..) , drawObjects @@ -9,7 +11,8 @@ import Data.Maybe ( fromJust, isJust ) import Graphics.Rendering.OpenGL.Raw import qualified Graphics.Gloss.Data.Color as Gloss -import Graphics.UI.GLUT +import Graphics.UI.GLUT hiding ( Points, Cylinder, Line, Plane, Cube, Sphere, Triangle ) +import qualified Graphics.UI.GLUT as GLUT import SpatialMath @@ -23,46 +26,36 @@ setMaterialDiffuse col = materialDiffuse Front $= (glColorOfColor col) 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 - | VisLine [Xyz a] 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 - | VisPoints [Xyz a] (Maybe GLfloat) Gloss.Color + | Trans (Xyz a) (VisObject a) + | RotQuat (Quat a) (VisObject a) + | RotEulerRad (Euler a) (VisObject a) + | RotEulerDeg (Euler a) (VisObject a) -- degrees more efficient + | Scale (a,a,a) (VisObject a) + | Cylinder (a,a) Gloss.Color + | Box (a,a,a) Flavour Gloss.Color + | Cube a Flavour Gloss.Color + | Sphere a Flavour Gloss.Color + | Ellipsoid (a,a,a) Flavour Gloss.Color + | Line [Xyz a] Gloss.Color + | Line' [(Xyz a,Gloss.Color)] + | Arrow (a,a) (Xyz a) Gloss.Color + | Axes (a,a) + | Plane (Xyz a) Gloss.Color Gloss.Color + | Triangle (Xyz a) (Xyz a) (Xyz a) Gloss.Color + | Quad (Xyz a) (Xyz a) (Xyz a) (Xyz a) Gloss.Color + | Text3d String (Xyz a) BitmapFont Gloss.Color + | Text2d String (a,a) BitmapFont Gloss.Color + | Points [Xyz a] (Maybe GLfloat) Gloss.Color + | Custom (IO ()) -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 - 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 (VisLine' xyzcs) = VisLine' $ map (\(xyz,col) -> (fmap f xyz, col)) xyzcs - 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 f (VisPoints xyz s col) = VisPoints (map (fmap f) xyz) s col - fmap _ (VisCustom f) = VisCustom f +deriving instance Functor VisObject setPerspectiveMode :: IO () setPerspectiveMode = do - (_, Size w h) <- get viewport + (_, Size w h) <- GLUT.get viewport matrixMode $= Projection loadIdentity - perspective 40 (fromIntegral w / fromIntegral h) 0.1 100 + perspective 40 (fromIntegral w / fromIntegral h) 0.1 1000 matrixMode $= Modelview 0 drawObjects :: VisObject GLdouble -> IO () @@ -74,8 +67,36 @@ -- list of objects drawObject (VisObjects xs) = mapM_ drawObject xs +-- list of objects +drawObject (Trans (Xyz x y z) visobj) = + preservingMatrix $ do + translate (Vector3 x y z :: Vector3 GLdouble) + drawObject visobj + +drawObject (RotQuat (Quat q0 q1 q2 q3) visobj) = + preservingMatrix $ do + rotate (2 * acos q0 *180/pi :: GLdouble) (Vector3 q1 q2 q3) + drawObject visobj + +drawObject (RotEulerRad euler visobj) = + drawObject $ RotEulerDeg (fmap ((180/pi)*) euler) visobj + +drawObject (RotEulerDeg (Euler yaw pitch roll) visobj) = + preservingMatrix $ do + rotate yaw (Vector3 0 0 1) + rotate pitch (Vector3 0 1 0) + rotate roll (Vector3 1 0 0) + drawObject visobj + +drawObject (Scale (sx,sy,sz) visobj) = + preservingMatrix $ do + normalize $= Enabled + scale sx sy sz + drawObject visobj + normalize $= Disabled + -- triangle -drawObject (VisTriangle (Xyz x0 y0 z0) (Xyz x1 y1 z1) (Xyz x2 y2 z2) col) = +drawObject (Triangle (Xyz x0 y0 z0) (Xyz x1 y1 z1) (Xyz x2 y2 z2) col) = preservingMatrix $ do setMaterialDiffuse col setColor col @@ -86,7 +107,7 @@ glEnd -- quad -drawObject (VisQuad (Xyz x0 y0 z0) (Xyz x1 y1 z1) (Xyz x2 y2 z2) (Xyz x3 y3 z3) col) = +drawObject (Quad (Xyz x0 y0 z0) (Xyz x1 y1 z1) (Xyz x2 y2 z2) (Xyz x3 y3 z3) col) = preservingMatrix $ do lighting $= Disabled setColor col @@ -99,13 +120,11 @@ lighting $= Enabled -- cylinder -drawObject (VisCylinder (height,radius) (Xyz x y z) (Quat q0 q1 q2 q3) col) = +drawObject (Cylinder (height,radius) 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 @@ -146,42 +165,34 @@ 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) = +drawObject (Sphere r 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 + renderObject flav (GLUT.Sphere' (realToFrac r) 20 20) +-- ellipsoid +drawObject (Ellipsoid (sx,sy,sz) flav col) = drawObject $ Scale (sx,sy,sz) $ Sphere 1 flav col + -- box -drawObject (VisBox (dx,dy,dz) (Xyz x y z) (Quat q0 q1 q2 q3) flav col) = +drawObject (Box (dx,dy,dz) flav col) = drawObject $ Scale (dx,dy,dz) $ Cube 1 flav col + +drawObject (Cube r 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 + renderObject flav (GLUT.Cube (realToFrac r)) -- line -drawObject (VisLine path col) = +drawObject (Line path col) = preservingMatrix $ do lighting $= Disabled setColor col - renderPrimitive LineStrip $ mapM_ (\(Xyz x' y' z') -> vertex$Vertex3 x' y' z') path + renderPrimitive LineStrip $ mapM_ (\(Xyz x' y' z') -> vertex $ Vertex3 x' y' z') path lighting $= Enabled -- line where you set the color at each vertex -drawObject (VisLine' pathcols) = +drawObject (Line' pathcols) = preservingMatrix $ do lighting $= Disabled @@ -196,16 +207,15 @@ lighting $= Enabled -- plane -drawObject (VisPlane (Xyz x y z) offset col1 col2) = +drawObject (Plane (Xyz x y z) col1 col2) = preservingMatrix $ do - let norm = 1/(sqrt $ x*x + y*y + z*z) - x' = x*norm - y' = y*norm - z' = z*norm + let normInv = 1/(sqrt $ x*x + y*y + z*z) + x' = x*normInv + y' = y*normInv + z' = z*normInv 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 @@ -219,17 +229,22 @@ 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]] + let drawWithEps eps' = do + mapM_ drawObject $ concat [[ Line [ Xyz (-r) y0 eps' + , Xyz r y0 eps' + ] col1 + , Line [ Xyz x0 (-r) eps', + Xyz x0 r eps' + ] col1 + ] | x0 <- [-r,-r+r/n..r], y0 <- [-r,-r+r/n..r]] + drawWithEps eps + drawWithEps (-eps) + glEnable gl_BLEND -- arrow -drawObject (VisArrow (size, aspectRatio) (Xyz x0 y0 z0) (Xyz x y z) col) = +drawObject (Arrow (size, aspectRatio) (Xyz x y z) col) = preservingMatrix $ do let numSlices = 8 numStacks = 15 @@ -241,36 +256,32 @@ 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 + drawObject $ Cylinder (cylinderHeight, cylinderRadius) col -- cone setMaterialDiffuse col setColor col translate (Vector3 0 0 cylinderHeight :: Vector3 GLdouble) - renderObject Solid (Cone coneRadius coneHeight numSlices numStacks) + renderObject Solid (GLUT.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) +drawObject (Axes (size, aspectRatio)) = preservingMatrix $ do + let xAxis = Arrow (size, aspectRatio) (Xyz 1 0 0) (Gloss.makeColor 1 0 0 1) + yAxis = Arrow (size, aspectRatio) (Xyz 0 1 0) (Gloss.makeColor 0 1 0 1) + zAxis = Arrow (size, aspectRatio) (Xyz 0 0 1) (Gloss.makeColor 0 0 1 1) drawObject $ VisObjects [xAxis, yAxis, zAxis] -drawObject (VisCustom f) = preservingMatrix f +drawObject (Custom f) = preservingMatrix f -drawObject (Vis3dText string (Xyz x y z) font col) = preservingMatrix $ do +drawObject (Text3d 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 +drawObject (Text2d string (x,y) font col) = preservingMatrix $ do lighting $= Disabled setColor col @@ -288,13 +299,13 @@ setPerspectiveMode lighting $= Enabled -drawObject (VisPoints xyzs ps col) = +drawObject (Points xyzs ps col) = preservingMatrix $ do lighting $= Disabled setColor col s' <- get pointSize when (isJust ps) $ pointSize $= (fromJust ps) - renderPrimitive Points $ mapM_ (\(Xyz x' y' z') -> vertex$Vertex3 x' y' z') xyzs + renderPrimitive GLUT.Points $ mapM_ (\(Xyz x' y' z') -> vertex $ Vertex3 x' y' z') xyzs pointSize $= s' lighting $= Enabled 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.4.3 +version: 0.5.0 stability: Experimental synopsis: Painless 3D graphics, no affiliation with gloss description:{ @@ -32,7 +32,7 @@ GLUT == 2.3.*, time == 1.4.*, OpenGLRaw == 1.2.*, - spatial-math >= 0.1.2 && < 0.2, + spatial-math >= 0.1.7 && < 0.2, gloss ghc-options: -O2