not-gloss 0.4.3 → 0.5.0
raw patch · 4 files changed
+159/−123 lines, 4 filesdep ~spatial-math
Dependency ranges changed: spatial-math
Files
- Vis/Interface.hs +40/−20
- Vis/Vis.hs +18/−13
- Vis/VisObject.hs +99/−88
- not-gloss.cabal +2/−2
Vis/Interface.hs view
@@ -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
Vis/Vis.hs view
@@ -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)
Vis/VisObject.hs view
@@ -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
not-gloss.cabal view
@@ -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