not-gloss 0.7.0.0 → 0.7.0.1
raw patch · 13 files changed
+1100/−1037 lines, 13 filesdep +cerealdep ~OpenGLRawdep ~spatial-math
Dependencies added: cereal
Dependency ranges changed: OpenGLRaw, spatial-math
Files
- Vis.hs +0/−37
- Vis/Camera.hs +0/−97
- Vis/GlossColor.hs +0/−250
- Vis/Interface.hs +0/−126
- Vis/Vis.hs +0/−208
- Vis/VisObject.hs +0/−316
- not-gloss.cabal +5/−3
- src/Vis.hs +37/−0
- src/Vis/Camera.hs +102/−0
- src/Vis/GlossColor.hs +250/−0
- src/Vis/Interface.hs +126/−0
- src/Vis/Vis.hs +215/−0
- src/Vis/VisObject.hs +365/−0
− Vis.hs
@@ -1,37 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--module Vis ( Options(..)- , defaultOpts- , display- , animate- , simulate- , play- , animateIO- , simulateIO- , playIO- , VisObject(..)- , SpecialKey(..)- , BitmapFont(..)- , Flavour(..)- , module Vis.GlossColor- ) where--import Graphics.UI.GLUT ( SpecialKey(..), BitmapFont(..), Flavour(..) )--import Vis.Vis ( Options(..) )-import Vis.Interface ( display, animate, simulate, play, animateIO, simulateIO, playIO )-import Vis.VisObject ( VisObject(..) )-import Vis.GlossColor---- | Some reasonable default options.--- Consider changing the window name with something like:------ > myOptions = defaultOpts {optWindowName = "my rad program"}-defaultOpts :: Options-defaultOpts =- Options- { optBackgroundColor = Nothing- , optWindowSize = Nothing- , optWindowPosition = Nothing- , optWindowName = "not-gloss"- }
− Vis/Camera.hs
@@ -1,97 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--module Vis.Camera ( Camera0(..)- , Camera(..)- , makeCamera- , setCamera- , cameraMotion- , cameraKeyboardMouse- ) where--import Graphics.UI.GLUT-import SpatialMath ( V3(..) )--data Camera0 = Camera0 { phi0 :: GLdouble- , theta0 :: GLdouble- , rho0 :: GLdouble- }--data Camera = Camera { phi :: GLdouble- , theta :: GLdouble- , rho :: GLdouble- , pos :: V3 GLdouble- , ballX :: GLint- , ballY :: GLint - , leftButton :: GLint- , rightButton :: GLint- }--makeCamera :: Camera0 -> Camera-makeCamera camera0 = Camera { phi = phi0 camera0- , theta = theta0 camera0- , rho = rho0 camera0- , pos = V3 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- V3 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' (V3 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 V3 nextX nextY z0- else V3 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)- (Char 'e', Down) -> 0.9 * (rho camera)- (Char 'q', Down) -> 1.1 * (rho camera)- _ -> rho camera
− Vis/GlossColor.hs
@@ -1,250 +0,0 @@--- Copyright (c) 2010-2012 Benjamin Lippmeier --- --- Permission is hereby granted, free of charge, to any person--- obtaining a copy of this software and associated documentation--- files (the "Software"), to deal in the Software without--- restriction, including without limitation the rights to use,--- copy, modify, merge, publish, distribute, sublicense, and/or sell--- copies of the Software, and to permit persons to whom the--- Software is furnished to do so, subject to the following--- condition:--- --- The above copyright notice and this permission notice shall be--- included in all copies or substantial portions of the Software.--{-# OPTIONS_GHC #-}---- | Predefined and custom colors.-module Vis.GlossColor- ( - -- ** Color data type- Color- , makeColor- , makeColor'- , makeColor8- , rawColor- , rgbaOfColor-- -- ** Color functions- , mixColors- , addColors- , dim, bright- , light, dark-- -- ** Pre-defined colors- , greyN, black, white- -- *** Primary- , red, green, blue- -- *** Secondary- , yellow, cyan, magenta- - -- *** Tertiary- , rose, violet, azure, aquamarine, chartreuse, orange- )-where---- | An abstract color value.--- We keep the type abstract so we can be sure that the components--- are in the required range. To make a custom color use 'makeColor'.-data Color- -- | Holds the color components. All components lie in the range [0..1.- = RGBA !Float !Float !Float !Float- deriving (Show, Eq)---instance Num Color where- {-# INLINE (+) #-}- (+) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _)- = RGBA (r1 + r2) (g1 + g2) (b1 + b2) 1-- {-# INLINE (-) #-}- (-) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _)- = RGBA (r1 - r2) (g1 - g2) (b1 - b2) 1-- {-# INLINE (*) #-}- (*) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _)- = RGBA (r1 * r2) (g1 * g2) (b1 * b2) 1-- {-# INLINE abs #-}- abs (RGBA r1 g1 b1 _)- = RGBA (abs r1) (abs g1) (abs b1) 1-- {-# INLINE signum #-}- signum (RGBA r1 g1 b1 _)- = RGBA (signum r1) (signum g1) (signum b1) 1- - {-# INLINE fromInteger #-}- fromInteger i- = let f = fromInteger i- in RGBA f f f 1----- | Make a custom color. All components are clamped to the range [0..1].-makeColor - :: Float -- ^ Red component.- -> Float -- ^ Green component.- -> Float -- ^ Blue component.- -> Float -- ^ Alpha component.- -> Color--makeColor r g b a- = clampColor - $ RGBA r g b a-{-# INLINE makeColor #-}----- | Make a custom color. --- You promise that all components are clamped to the range [0..1]-makeColor' :: Float -> Float -> Float -> Float -> Color-makeColor' r g b a- = RGBA r g b a-{-# INLINE makeColor' #-}----- | Make a custom color. All components are clamped to the range [0..255].-makeColor8 - :: Int -- ^ Red component.- -> Int -- ^ Green component.- -> Int -- ^ Blue component.- -> Int -- ^ Alpha component.- -> Color--makeColor8 r g b a- = clampColor - $ RGBA (fromIntegral r / 255) - (fromIntegral g / 255)- (fromIntegral b / 255)- (fromIntegral a / 255)-{-# INLINE makeColor8 #-}-- --- | Take the RGBA components of a color.-rgbaOfColor :: Color -> (Float, Float, Float, Float)-rgbaOfColor (RGBA r g b a) = (r, g, b, a)-{-# INLINE rgbaOfColor #-}- ---- | Make a custom color.--- Components should be in the range [0..1] but this is not checked.-rawColor- :: Float -- ^ Red component.- -> Float -- ^ Green component.- -> Float -- ^ Blue component.- -> Float -- ^ Alpha component.- -> Color--rawColor = RGBA-{-# INLINE rawColor #-}----- Internal ---- | Clamp components of a color into the required range.-clampColor :: Color -> Color-clampColor cc- = let (r, g, b, a) = rgbaOfColor cc- in RGBA (min 1 r) (min 1 g) (min 1 b) (min 1 a)---- | Normalise a color to the value of its largest RGB component.-normaliseColor :: Color -> Color-normaliseColor cc- = let (r, g, b, a) = rgbaOfColor cc- m = maximum [r, g, b]- in RGBA (r / m) (g / m) (b / m) a----- Color functions ---------------------------------------------------------------- | Mix two colors with the given ratios.-mixColors - :: Float -- ^ Ratio of first color.- -> Float -- ^ Ratio of second color.- -> Color -- ^ First color.- -> Color -- ^ Second color.- -> Color -- ^ Resulting color.--mixColors ratio1 ratio2 c1 c2- = let RGBA r1 g1 b1 a1 = c1- RGBA r2 g2 b2 a2 = c2-- total = ratio1 + ratio2- m1 = ratio1 / total- m2 = ratio2 / total-- in RGBA (m1 * r1 + m2 * r2)- (m1 * g1 + m2 * g2)- (m1 * b1 + m2 * b2)- (m1 * a1 + m2 * a2)----- | Add RGB components of a color component-wise, then normalise--- them to the highest resulting one. The alpha components are averaged.-addColors :: Color -> Color -> Color-addColors c1 c2- = let RGBA r1 g1 b1 a1 = c1- RGBA r2 g2 b2 a2 = c2-- in normaliseColor - $ RGBA (r1 + r2)- (g1 + g2)- (b1 + b2)- ((a1 + a2) / 2)----- | Make a dimmer version of a color, scaling towards black.-dim :: Color -> Color-dim (RGBA r g b a)- = RGBA (r / 1.2) (g / 1.2) (b / 1.2) a-- --- | Make a brighter version of a color, scaling towards white.-bright :: Color -> Color-bright (RGBA r g b a)- = clampColor- $ RGBA (r * 1.2) (g * 1.2) (b * 1.2) a----- | Lighten a color, adding white.-light :: Color -> Color-light (RGBA r g b a)- = clampColor- $ RGBA (r + 0.2) (g + 0.2) (b + 0.2) a- - --- | Darken a color, adding black.-dark :: Color -> Color-dark (RGBA r g b a)- = clampColor- $ RGBA (r - 0.2) (g - 0.2) (b - 0.2) a----- Pre-defined Colors ------------------------------------------------------------ | A greyness of a given magnitude.-greyN :: Float -- ^ Range is 0 = black, to 1 = white.- -> Color-greyN n = RGBA n n n 1.0--black, white :: Color-black = RGBA 0.0 0.0 0.0 1.0-white = RGBA 1.0 1.0 1.0 1.0---- Colors from the additive color wheel.-red, green, blue :: Color-red = RGBA 1.0 0.0 0.0 1.0-green = RGBA 0.0 1.0 0.0 1.0-blue = RGBA 0.0 0.0 1.0 1.0---- secondary-yellow, cyan, magenta :: Color-yellow = addColors red green-cyan = addColors green blue-magenta = addColors red blue---- tertiary-rose, violet, azure, aquamarine, chartreuse, orange :: Color-rose = addColors red magenta-violet = addColors magenta blue-azure = addColors blue cyan-aquamarine = addColors cyan green-chartreuse = addColors green yellow-orange = addColors yellow red
− Vis/Interface.hs
@@ -1,126 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--module Vis.Interface ( display- , animate- , animateIO- , simulate- , simulateIO- , play- , playIO- ) where--import Graphics.UI.GLUT ( Key, KeyState, Position, Modifiers, Cursor(..) )--import Vis.Vis ( Options, vis )-import Vis.Camera ( makeCamera, Camera0(..), setCamera, cameraMotion, cameraKeyboardMouse )-import Vis.VisObject ( VisObject(..) )---- | draw a static image-display :: Real b =>- Options -- ^ user options- -> VisObject b -- ^ object to draw- -> IO ()-display opts visobjects = animate opts (\_ -> visobjects)------ | display an animation-animate :: Real b =>- Options -- ^ user options- -> (Float -> VisObject b) -- ^ draw function- -> IO ()-animate opts userDrawFun = animateIO opts (return . userDrawFun)---- | display an animation impurely-animateIO :: Real b =>- Options -- ^ user options- -> (Float -> IO (VisObject b)) -- ^ draw function- -> IO ()-animateIO opts userDrawFun =- vis opts 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) = do- obs <- userDrawFun time- return (obs, Nothing)- 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----- | run a simulation-simulate :: Real b =>- Options -- ^ user options- -> 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 opts ts state0 userDrawFun userSimFun =- simulateIO opts ts state0 (return . userDrawFun) (\t -> return . (userSimFun t))---- | run a simulation impurely-simulateIO :: Real b =>- Options -- ^ user options- -> 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 opts ts userState0 userDrawFun userSimFun =- vis opts ts (userState0, cameraState0) simFun drawFun setCameraFun (Just kmCallback) (Just motionCallback) Nothing- where- drawFun ((userState, _),_) = do- obs <- userDrawFun userState- return (obs, Nothing)-- 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------- | play a game-play :: Real b =>- Options -- ^ user options- -> 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)- -> (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 opts ts userState0 userDrawFun userSimFun =- vis opts ts userState0 simFun drawFun- where- drawFun (userState, _) = return $ userDrawFun userState- simFun (userState,time) = return $ userSimFun time userState------- | play a game impurely-playIO :: Real b =>- Options -- ^ user options- -> 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)- -> (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 opts ts userState0 userDrawFun userSimFun =- vis opts ts userState0 simFun drawFun- where- drawFun (userState, _) = userDrawFun userState- simFun (userState,time) = userSimFun time userState
− Vis/Vis.hs
@@ -1,208 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--module Vis.Vis ( Options(..)- , vis- , FullState- ) where--import Data.Maybe ( fromMaybe )-import Data.IORef ( newIORef )-import System.Exit ( exitSuccess )-import Data.Time.Clock ( getCurrentTime, diffUTCTime, addUTCTime )-import Control.Concurrent ( MVar, readMVar, swapMVar, newMVar, takeMVar, putMVar, forkIO, threadDelay )-import Control.Monad ( unless, forever )-import Graphics.UI.GLUT-import Graphics.Rendering.OpenGL.Raw--import Vis.VisObject ( VisObject(..), drawObjects, setPerspectiveMode )-import qualified Vis.GlossColor as GC---- | user state and internal states-type FullState a = (a, Float)--data Options =- Options- { -- ^ optional background color- optBackgroundColor :: Maybe GC.Color- -- ^ optional (x,y) window size in pixels- , optWindowSize :: Maybe (Int,Int)- -- ^ optional (x,y) window origin in pixels- , optWindowPosition :: Maybe (Int,Int)- -- ^ window name- , optWindowName :: String- } deriving Show--myGlInit :: Options -> IO ()-myGlInit opts = 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-- (xsize, ysize) = fromMaybe (xf - x0, yf - y0) (optWindowSize opts)- (xpos, ypos) = fromMaybe (x0,y0) (optWindowPosition opts)-- initialWindowSize $= Size (fromIntegral xsize) (fromIntegral ysize)- initialWindowPosition $= Position (fromIntegral xpos) (fromIntegral ypos)- _ <- createWindow (optWindowName opts)-- case optBackgroundColor opts of- Nothing -> clearColor $= Color4 0 0 0 0- Just col -> clearColor $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)- where- (r,g,b,a) = GC.rgbaOfColor col- 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 =>- Options -- ^ user options- -> 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- -> (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 opts ts x0 userSimFun userDraw userSetCamera- userKeyMouseCallback userMotionCallback userPassiveMotionCallback = do- -- init glut/scene- _ <- getArgsAndInitialize- - myGlInit opts- - -- 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,cursor') <- userDraw x- drawObjects $ (fmap realToFrac) visobs- case cursor' of Nothing -> return ()- Just cursor'' -> cursor $= cursor''-- 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) <- takeMVar stateMVar- putMVar stateMVar (cb state0' k0 k1 k2 k3, time)- postRedisplay Nothing-- motionCallback' pos = case userMotionCallback of- Nothing -> return ()- Just cb -> do- (state0',ts') <- takeMVar stateMVar- putMVar stateMVar (cb state0' pos, ts')- postRedisplay Nothing-- passiveMotionCallback' pos = case userPassiveMotionCallback of- Nothing -> return ()- Just cb -> do- (state0',ts') <- takeMVar stateMVar- putMVar stateMVar (cb state0' pos, 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
@@ -1,316 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# Language StandaloneDeriving #-}-{-# Language DeriveFunctor #-}--module Vis.VisObject ( VisObject(..)- , drawObjects- , setPerspectiveMode- ) where--import Control.Monad ( when )-import Data.Maybe ( fromJust, isJust )-import Graphics.Rendering.OpenGL.Raw-import Graphics.UI.GLUT hiding ( Points, Cylinder, Line, Plane, Cube, Sphere, Triangle )-import qualified Graphics.UI.GLUT as GLUT--import SpatialMath--import qualified Vis.GlossColor as GlossColor--glColorOfColor :: GlossColor.Color -> Color4 GLfloat-glColorOfColor = (\(r,g,b,a) -> fmap realToFrac (Color4 r g b a)) . GlossColor.rgbaOfColor--setColor :: GlossColor.Color -> IO ()-setColor = color . glColorOfColor--setMaterialDiffuse :: GlossColor.Color -> IO ()-setMaterialDiffuse col = materialDiffuse Front $= (glColorOfColor col)--data VisObject a = VisObjects [VisObject a]- | Trans (V3 a) (VisObject a)- | RotQuat (Quaternion a) (VisObject a)- | RotDcm (M33 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) GlossColor.Color- | Box (a,a,a) Flavour GlossColor.Color- | Cube a Flavour GlossColor.Color- | Sphere a Flavour GlossColor.Color- | Ellipsoid (a,a,a) Flavour GlossColor.Color- | Line [V3 a] GlossColor.Color- | Line' [(V3 a,GlossColor.Color)]- | Arrow (a,a) (V3 a) GlossColor.Color- | Axes (a,a)- | Plane (V3 a) GlossColor.Color GlossColor.Color- | Triangle (V3 a) (V3 a) (V3 a) GlossColor.Color- | Quad (V3 a) (V3 a) (V3 a) (V3 a) GlossColor.Color- | Text3d String (V3 a) BitmapFont GlossColor.Color- | Text2d String (a,a) BitmapFont GlossColor.Color- | Points [V3 a] (Maybe GLfloat) GlossColor.Color- | Custom (IO ())--deriving instance Functor VisObject--setPerspectiveMode :: IO ()-setPerspectiveMode = do- (_, Size w h) <- GLUT.get viewport- matrixMode $= Projection- loadIdentity- perspective 40 (fromIntegral w / fromIntegral h) 0.1 1000- matrixMode $= Modelview 0--drawObjects :: VisObject GLdouble -> IO ()-drawObjects objects = do- setPerspectiveMode- drawObject objects--drawObject :: VisObject GLdouble -> IO ()--- list of objects-drawObject (VisObjects xs) = mapM_ drawObject xs---- list of objects-drawObject (Trans (V3 x y z) visobj) =- preservingMatrix $ do- translate (Vector3 x y z :: Vector3 GLdouble)- drawObject visobj--drawObject (RotQuat (Quaternion q0 (V3 q1 q2 q3)) visobj) =- preservingMatrix $ do- rotate (2 * acos q0 *180/pi :: GLdouble) (Vector3 q1 q2 q3)- drawObject visobj--drawObject (RotDcm dcm visobject) =- drawObject (RotQuat (quatOfDcm dcm) visobject)--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 (Triangle (V3 x0 y0 z0) (V3 x1 y1 z1) (V3 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 (Quad (V3 x0 y0 z0) (V3 x1 y1 z1) (V3 x2 y2 z2) (V3 x3 y3 z3) col) =- preservingMatrix $ do- lighting $= Disabled- setColor col- glBegin gl_QUADS- glVertex3d x0 y0 z0- glVertex3d x1 y1 z1- glVertex3d x2 y2 z2- glVertex3d x3 y3 z3- glEnd- lighting $= Enabled---- cylinder-drawObject (Cylinder (height,radius) col) =- preservingMatrix $ do- setMaterialDiffuse col- setColor col- - -- 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 (Sphere r flav col) =- preservingMatrix $ do- setMaterialDiffuse col- setColor col- 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 (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- renderObject flav (GLUT.Cube (realToFrac r))---- line-drawObject (Line path col) =- preservingMatrix $ do- lighting $= Disabled- setColor col- renderPrimitive LineStrip $ mapM_ (\(V3 x' y' z') -> vertex $ Vertex3 x' y' z') path- lighting $= Enabled---- line where you set the color at each vertex-drawObject (Line' pathcols) =- preservingMatrix $ do- lighting $= Disabled- - glBegin gl_LINE_STRIP- let f (xyz, col) = do- let V3 x y z = fmap realToFrac xyz- setMaterialDiffuse col- setColor col- glVertex3f x y z- mapM_ f pathcols- glEnd- lighting $= Enabled---- plane-drawObject (Plane (V3 x y z) col1 col2) =- preservingMatrix $ do- 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- 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- let drawWithEps eps' = do- mapM_ drawObject $ concat [[ Line [ V3 (-r) y0 eps'- , V3 r y0 eps'- ] col1- , Line [ V3 x0 (-r) eps',- V3 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 (Arrow (size, aspectRatio) (V3 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- - rotate rotAngle rotAxis- - -- cylinder- drawObject $ Cylinder (cylinderHeight, cylinderRadius) col- -- cone- setMaterialDiffuse col- setColor col- translate (Vector3 0 0 cylinderHeight :: Vector3 GLdouble)- renderObject Solid (GLUT.Cone coneRadius coneHeight numSlices numStacks)--drawObject (Axes (size, aspectRatio)) = preservingMatrix $ do- let xAxis = Arrow (size, aspectRatio) (V3 1 0 0) (GlossColor.makeColor 1 0 0 1)- yAxis = Arrow (size, aspectRatio) (V3 0 1 0) (GlossColor.makeColor 0 1 0 1)- zAxis = Arrow (size, aspectRatio) (V3 0 0 1) (GlossColor.makeColor 0 0 1 1)- drawObject $ VisObjects [xAxis, yAxis, zAxis]--drawObject (Custom f) = preservingMatrix f--drawObject (Text3d string (V3 x y z) font col) = preservingMatrix $ do- lighting $= Disabled- setColor col- glRasterPos3d x y z- renderString font string- lighting $= Enabled--drawObject (Text2d 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--drawObject (Points xyzs ps col) =- preservingMatrix $ do- lighting $= Disabled- setColor col- s' <- get pointSize- when (isJust ps) $ pointSize $= (fromJust ps)- renderPrimitive GLUT.Points $ mapM_ (\(V3 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.7.0.0+version: 0.7.0.1 stability: Experimental synopsis: Painless 3D graphics, no affiliation with gloss description:{@@ -26,6 +26,7 @@ cabal-version: >=1.8 library+ hs-source-dirs: src exposed-modules: Vis Vis.Camera Vis.Interface@@ -38,8 +39,9 @@ build-depends: base >= 4.5 && < 5, GLUT >= 2.3.0, time >= 1.4.0,- OpenGLRaw >= 1.2.0,- spatial-math >= 0.2.0+ OpenGLRaw >= 2.3.0,+ spatial-math >= 0.2.1.1,+ cereal ghc-options: -O2
+ src/Vis.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -Wall #-}++module Vis ( Options(..)+ , defaultOpts+ , display+ , animate+ , simulate+ , play+ , animateIO+ , simulateIO+ , playIO+ , VisObject(..)+ , SpecialKey(..)+ , BitmapFont(..)+ , Flavour(..)+ , module Vis.GlossColor+ ) where++import Graphics.UI.GLUT ( SpecialKey(..), BitmapFont(..), Flavour(..) )++import Vis.Vis ( Options(..) )+import Vis.Interface ( display, animate, simulate, play, animateIO, simulateIO, playIO )+import Vis.VisObject ( VisObject(..) )+import Vis.GlossColor++-- | Some reasonable default options.+-- Consider changing the window name with something like:+--+-- > myOptions = defaultOpts {optWindowName = "my rad program"}+defaultOpts :: Options+defaultOpts =+ Options+ { optBackgroundColor = Nothing+ , optWindowSize = Nothing+ , optWindowPosition = Nothing+ , optWindowName = "not-gloss"+ }
+ src/Vis/Camera.hs view
@@ -0,0 +1,102 @@+{-# OPTIONS_GHC -Wall #-}++module Vis.Camera ( Camera0(..)+ , Camera(..)+ , makeCamera+ , setCamera+ , cameraMotion+ , cameraKeyboardMouse+ ) where++import Graphics.UI.GLUT ( GLdouble, GLint+ , Vector3(..), Vertex3(..)+ , Position(..), MouseButton(..), Key(..), KeyState(..)+ )+import qualified Graphics.UI.GLUT as GLUT++import SpatialMath ( V3(..) )++data Camera0 = Camera0 { phi0 :: GLdouble+ , theta0 :: GLdouble+ , rho0 :: GLdouble+ }++data Camera = Camera { phi :: GLdouble+ , theta :: GLdouble+ , rho :: GLdouble+ , pos :: V3 GLdouble+ , ballX :: GLint+ , ballY :: GLint + , leftButton :: GLint+ , rightButton :: GLint+ }++makeCamera :: Camera0 -> Camera+makeCamera camera0 = Camera { phi = phi0 camera0+ , theta = theta0 camera0+ , rho = rho0 camera0+ , pos = V3 0 0 0+ , ballX = (-1)+ , ballY = (-1)+ , leftButton = 0+ , rightButton = 0+ }++setCamera :: Camera -> IO ()+setCamera camera = GLUT.lookAt (Vertex3 xc yc zc) (Vertex3 x0 y0 z0) (Vector3 0 0 (-1))+ where+ V3 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' (V3 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 V3 nextX nextY z0+ else V3 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)+ (Char 'e', Down) -> 0.9 * (rho camera)+ (Char 'q', Down) -> 1.1 * (rho camera)+ _ -> rho camera
+ src/Vis/GlossColor.hs view
@@ -0,0 +1,250 @@+-- Copyright (c) 2010-2012 Benjamin Lippmeier +-- +-- Permission is hereby granted, free of charge, to any person+-- obtaining a copy of this software and associated documentation+-- files (the "Software"), to deal in the Software without+-- restriction, including without limitation the rights to use,+-- copy, modify, merge, publish, distribute, sublicense, and/or sell+-- copies of the Software, and to permit persons to whom the+-- Software is furnished to do so, subject to the following+-- condition:+-- +-- The above copyright notice and this permission notice shall be+-- included in all copies or substantial portions of the Software.++{-# OPTIONS_GHC #-}++-- | Predefined and custom colors.+module Vis.GlossColor+ ( + -- ** Color data type+ Color+ , makeColor+ , makeColor'+ , makeColor8+ , rawColor+ , rgbaOfColor++ -- ** Color functions+ , mixColors+ , addColors+ , dim, bright+ , light, dark++ -- ** Pre-defined colors+ , greyN, black, white+ -- *** Primary+ , red, green, blue+ -- *** Secondary+ , yellow, cyan, magenta+ + -- *** Tertiary+ , rose, violet, azure, aquamarine, chartreuse, orange+ )+where++-- | An abstract color value.+-- We keep the type abstract so we can be sure that the components+-- are in the required range. To make a custom color use 'makeColor'.+data Color+ -- | Holds the color components. All components lie in the range [0..1.+ = RGBA !Float !Float !Float !Float+ deriving (Show, Eq)+++instance Num Color where+ {-# INLINE (+) #-}+ (+) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _)+ = RGBA (r1 + r2) (g1 + g2) (b1 + b2) 1++ {-# INLINE (-) #-}+ (-) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _)+ = RGBA (r1 - r2) (g1 - g2) (b1 - b2) 1++ {-# INLINE (*) #-}+ (*) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _)+ = RGBA (r1 * r2) (g1 * g2) (b1 * b2) 1++ {-# INLINE abs #-}+ abs (RGBA r1 g1 b1 _)+ = RGBA (abs r1) (abs g1) (abs b1) 1++ {-# INLINE signum #-}+ signum (RGBA r1 g1 b1 _)+ = RGBA (signum r1) (signum g1) (signum b1) 1+ + {-# INLINE fromInteger #-}+ fromInteger i+ = let f = fromInteger i+ in RGBA f f f 1+++-- | Make a custom color. All components are clamped to the range [0..1].+makeColor + :: Float -- ^ Red component.+ -> Float -- ^ Green component.+ -> Float -- ^ Blue component.+ -> Float -- ^ Alpha component.+ -> Color++makeColor r g b a+ = clampColor + $ RGBA r g b a+{-# INLINE makeColor #-}+++-- | Make a custom color. +-- You promise that all components are clamped to the range [0..1]+makeColor' :: Float -> Float -> Float -> Float -> Color+makeColor' r g b a+ = RGBA r g b a+{-# INLINE makeColor' #-}+++-- | Make a custom color. All components are clamped to the range [0..255].+makeColor8 + :: Int -- ^ Red component.+ -> Int -- ^ Green component.+ -> Int -- ^ Blue component.+ -> Int -- ^ Alpha component.+ -> Color++makeColor8 r g b a+ = clampColor + $ RGBA (fromIntegral r / 255) + (fromIntegral g / 255)+ (fromIntegral b / 255)+ (fromIntegral a / 255)+{-# INLINE makeColor8 #-}++ +-- | Take the RGBA components of a color.+rgbaOfColor :: Color -> (Float, Float, Float, Float)+rgbaOfColor (RGBA r g b a) = (r, g, b, a)+{-# INLINE rgbaOfColor #-}+ ++-- | Make a custom color.+-- Components should be in the range [0..1] but this is not checked.+rawColor+ :: Float -- ^ Red component.+ -> Float -- ^ Green component.+ -> Float -- ^ Blue component.+ -> Float -- ^ Alpha component.+ -> Color++rawColor = RGBA+{-# INLINE rawColor #-}+++-- Internal ++-- | Clamp components of a color into the required range.+clampColor :: Color -> Color+clampColor cc+ = let (r, g, b, a) = rgbaOfColor cc+ in RGBA (min 1 r) (min 1 g) (min 1 b) (min 1 a)++-- | Normalise a color to the value of its largest RGB component.+normaliseColor :: Color -> Color+normaliseColor cc+ = let (r, g, b, a) = rgbaOfColor cc+ m = maximum [r, g, b]+ in RGBA (r / m) (g / m) (b / m) a+++-- Color functions ------------------------------------------------------------++-- | Mix two colors with the given ratios.+mixColors + :: Float -- ^ Ratio of first color.+ -> Float -- ^ Ratio of second color.+ -> Color -- ^ First color.+ -> Color -- ^ Second color.+ -> Color -- ^ Resulting color.++mixColors ratio1 ratio2 c1 c2+ = let RGBA r1 g1 b1 a1 = c1+ RGBA r2 g2 b2 a2 = c2++ total = ratio1 + ratio2+ m1 = ratio1 / total+ m2 = ratio2 / total++ in RGBA (m1 * r1 + m2 * r2)+ (m1 * g1 + m2 * g2)+ (m1 * b1 + m2 * b2)+ (m1 * a1 + m2 * a2)+++-- | Add RGB components of a color component-wise, then normalise+-- them to the highest resulting one. The alpha components are averaged.+addColors :: Color -> Color -> Color+addColors c1 c2+ = let RGBA r1 g1 b1 a1 = c1+ RGBA r2 g2 b2 a2 = c2++ in normaliseColor + $ RGBA (r1 + r2)+ (g1 + g2)+ (b1 + b2)+ ((a1 + a2) / 2)+++-- | Make a dimmer version of a color, scaling towards black.+dim :: Color -> Color+dim (RGBA r g b a)+ = RGBA (r / 1.2) (g / 1.2) (b / 1.2) a++ +-- | Make a brighter version of a color, scaling towards white.+bright :: Color -> Color+bright (RGBA r g b a)+ = clampColor+ $ RGBA (r * 1.2) (g * 1.2) (b * 1.2) a+++-- | Lighten a color, adding white.+light :: Color -> Color+light (RGBA r g b a)+ = clampColor+ $ RGBA (r + 0.2) (g + 0.2) (b + 0.2) a+ + +-- | Darken a color, adding black.+dark :: Color -> Color+dark (RGBA r g b a)+ = clampColor+ $ RGBA (r - 0.2) (g - 0.2) (b - 0.2) a+++-- Pre-defined Colors ---------------------------------------------------------+-- | A greyness of a given magnitude.+greyN :: Float -- ^ Range is 0 = black, to 1 = white.+ -> Color+greyN n = RGBA n n n 1.0++black, white :: Color+black = RGBA 0.0 0.0 0.0 1.0+white = RGBA 1.0 1.0 1.0 1.0++-- Colors from the additive color wheel.+red, green, blue :: Color+red = RGBA 1.0 0.0 0.0 1.0+green = RGBA 0.0 1.0 0.0 1.0+blue = RGBA 0.0 0.0 1.0 1.0++-- secondary+yellow, cyan, magenta :: Color+yellow = addColors red green+cyan = addColors green blue+magenta = addColors red blue++-- tertiary+rose, violet, azure, aquamarine, chartreuse, orange :: Color+rose = addColors red magenta+violet = addColors magenta blue+azure = addColors blue cyan+aquamarine = addColors cyan green+chartreuse = addColors green yellow+orange = addColors yellow red
+ src/Vis/Interface.hs view
@@ -0,0 +1,126 @@+{-# OPTIONS_GHC -Wall #-}++module Vis.Interface ( display+ , animate+ , animateIO+ , simulate+ , simulateIO+ , play+ , playIO+ ) where++import Graphics.UI.GLUT ( Key, KeyState, Position, Modifiers, Cursor(..) )++import Vis.Vis ( Options, vis )+import Vis.Camera ( makeCamera, Camera0(..), setCamera, cameraMotion, cameraKeyboardMouse )+import Vis.VisObject ( VisObject(..) )++-- | draw a static image+display :: Real b =>+ Options -- ^ user options+ -> VisObject b -- ^ object to draw+ -> IO ()+display opts visobjects = animate opts (\_ -> visobjects)++---- | display an animation+animate :: Real b =>+ Options -- ^ user options+ -> (Float -> VisObject b) -- ^ draw function+ -> IO ()+animate opts userDrawFun = animateIO opts (return . userDrawFun)++-- | display an animation impurely+animateIO :: Real b =>+ Options -- ^ user options+ -> (Float -> IO (VisObject b)) -- ^ draw function+ -> IO ()+animateIO opts userDrawFun =+ vis opts 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) = do+ obs <- userDrawFun time+ return (obs, Nothing)+ 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+++-- | run a simulation+simulate :: Real b =>+ Options -- ^ user options+ -> 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 opts ts state0 userDrawFun userSimFun =+ simulateIO opts ts state0 (return . userDrawFun) (\t -> return . (userSimFun t))++-- | run a simulation impurely+simulateIO :: Real b =>+ Options -- ^ user options+ -> 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 opts ts userState0 userDrawFun userSimFun =+ vis opts ts (userState0, cameraState0) simFun drawFun setCameraFun (Just kmCallback) (Just motionCallback) Nothing+ where+ drawFun ((userState, _),_) = do+ obs <- userDrawFun userState+ return (obs, Nothing)++ 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+++---- | play a game+play :: Real b =>+ Options -- ^ user options+ -> 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)+ -> (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 opts ts userState0 userDrawFun userSimFun =+ vis opts ts userState0 simFun drawFun+ where+ drawFun (userState, _) = return $ userDrawFun userState+ simFun (userState,time) = return $ userSimFun time userState+++---- | play a game impurely+playIO :: Real b =>+ Options -- ^ user options+ -> 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)+ -> (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 opts ts userState0 userDrawFun userSimFun =+ vis opts ts userState0 simFun drawFun+ where+ drawFun (userState, _) = userDrawFun userState+ simFun (userState,time) = userSimFun time userState
+ src/Vis/Vis.hs view
@@ -0,0 +1,215 @@+{-# OPTIONS_GHC -Wall #-}++module Vis.Vis ( Options(..)+ , vis+ , FullState+ ) where++import Data.Maybe ( fromMaybe )+import Data.IORef ( newIORef )+import System.Exit ( exitSuccess )+import Data.Time.Clock ( getCurrentTime, diffUTCTime, addUTCTime )+import Control.Concurrent ( MVar, readMVar, swapMVar, newMVar, takeMVar, putMVar, forkIO, threadDelay )+import Control.Monad ( unless, forever )+import Graphics.UI.GLUT ( Capability(..), ClearBuffer(..), Color4(..), ColorMaterialParameter(..)+ , ComparisonFunction(..), Cursor(..), DisplayMode(..), Face(..)+ , Key(..), KeyState(..), Light(..), Modifiers(..), Position(..)+ , ShadingModel(..), Size(..)+ , DisplayCallback, ReshapeCallback+ , ($=)+ )+import qualified Graphics.UI.GLUT as GLUT+import Graphics.Rendering.OpenGL.Raw++import Vis.VisObject ( VisObject(..), drawObjects, setPerspectiveMode )+import qualified Vis.GlossColor as GC++-- | user state and internal states+type FullState a = (a, Float)++data Options =+ Options+ { -- ^ optional background color+ optBackgroundColor :: Maybe GC.Color+ -- ^ optional (x,y) window size in pixels+ , optWindowSize :: Maybe (Int,Int)+ -- ^ optional (x,y) window origin in pixels+ , optWindowPosition :: Maybe (Int,Int)+ -- ^ window name+ , optWindowName :: String+ } deriving Show++myGlInit :: Options -> IO ()+myGlInit opts = do+ GLUT.initialDisplayMode $= [ DoubleBuffered, RGBAMode, WithDepthBuffer ]++ Size x y <- GLUT.get GLUT.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++ (xsize, ysize) = fromMaybe (xf - x0, yf - y0) (optWindowSize opts)+ (xpos, ypos) = fromMaybe (x0,y0) (optWindowPosition opts)++ GLUT.initialWindowSize $= Size (fromIntegral xsize) (fromIntegral ysize)+ GLUT.initialWindowPosition $= Position (fromIntegral xpos) (fromIntegral ypos)+ _ <- GLUT.createWindow (optWindowName opts)++ case optBackgroundColor opts of+ Nothing -> GLUT.clearColor $= Color4 0 0 0 0+ Just col -> GLUT.clearColor $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)+ where+ (r,g,b,a) = GC.rgbaOfColor col+ GLUT.shadeModel $= Smooth+ GLUT.depthFunc $= Just Less+ GLUT.lighting $= Enabled+ GLUT.light (Light 0) $= Enabled+ GLUT.ambient (Light 0) $= Color4 1 1 1 1+ + GLUT.materialDiffuse Front $= Color4 0.5 0.5 0.5 1+ GLUT.materialSpecular Front $= Color4 1 1 1 1+ GLUT.materialShininess Front $= 100+ GLUT.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+ GLUT.clear [ ColorBuffer, DepthBuffer ]+ + -- draw the scene+ GLUT.preservingMatrix $ do+ -- set the camera's position and orientation+ setCameraFun+ + -- call user function+ state <- readMVar stateMVar+ userDrawFun state++ GLUT.flush+ GLUT.swapBuffers+ _ <- swapMVar visReadyMVar True+ GLUT.postRedisplay Nothing+++reshape :: ReshapeCallback+reshape size@(Size _ _) = do+ GLUT.viewport $= (Position 0 0, size)+ setPerspectiveMode+ GLUT.loadIdentity+ GLUT.postRedisplay Nothing+++vis :: Real b =>+ Options -- ^ user options+ -> 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+ -> (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 opts ts x0 userSimFun userDraw userSetCamera+ userKeyMouseCallback userMotionCallback userPassiveMotionCallback = do+ -- init glut/scene+ _ <- GLUT.getArgsAndInitialize+ + myGlInit opts+ + -- 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,cursor') <- userDraw x+ drawObjects $ (fmap realToFrac) visobs+ case cursor' of Nothing -> return ()+ Just cursor'' -> GLUT.cursor $= cursor''++ 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) <- takeMVar stateMVar+ putMVar stateMVar (cb state0' k0 k1 k2 k3, time)+ GLUT.postRedisplay Nothing++ motionCallback' pos = case userMotionCallback of+ Nothing -> return ()+ Just cb -> do+ (state0',ts') <- takeMVar stateMVar+ putMVar stateMVar (cb state0' pos, ts')+ GLUT.postRedisplay Nothing++ passiveMotionCallback' pos = case userPassiveMotionCallback of+ Nothing -> return ()+ Just cb -> do+ (state0',ts') <- takeMVar stateMVar+ putMVar stateMVar (cb state0' pos, ts')+ GLUT.postRedisplay Nothing++ GLUT.displayCallback $= drawScene stateMVar visReadyMVar setCamera makePictures+ GLUT.reshapeCallback $= Just reshape+ GLUT.keyboardMouseCallback $= Just exitOverride+ GLUT.motionCallback $= Just motionCallback'+ GLUT.passiveMotionCallback $= Just passiveMotionCallback'++ -- start main loop+ GLUT.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 <- GLUT.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++ GLUT.postRedisplay Nothing+ + -- need to sleep longer+ else threadDelay usRemaining
+ src/Vis/VisObject.hs view
@@ -0,0 +1,365 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# Language StandaloneDeriving #-}+{-# Language DeriveFunctor #-}+{-# Language DeriveGeneric #-}+{-# Language TypeSynonymInstances #-}++module Vis.VisObject ( VisObject(..)+ , drawObjects+ , setPerspectiveMode+ ) where++import GHC.Generics ( Generic )++import Control.Monad ( when )+import Data.Maybe ( fromJust, isJust )+import Data.Word ( Word8 )+import qualified Data.Serialize as S+import Graphics.Rendering.OpenGL.Raw+import qualified Graphics.UI.GLUT as GLUT+import Foreign.C.Types ( CFloat(..) )+import Graphics.UI.GLUT ( BitmapFont(..), Capability(..), Color4(..), Face(..)+ , Flavour(..), MatrixMode(..), PrimitiveMode(..), Size(..)+ , Vertex3(..), Vector3(..)+ , ($=)+ )++import SpatialMath++import qualified Vis.GlossColor as GlossColor++glColorOfColor :: GlossColor.Color -> Color4 GLfloat+glColorOfColor = (\(r,g,b,a) -> fmap realToFrac (Color4 r g b a)) . GlossColor.rgbaOfColor++setColor :: GlossColor.Color -> IO ()+setColor = GLUT.color . glColorOfColor++setMaterialDiffuse :: GlossColor.Color -> IO ()+setMaterialDiffuse col = GLUT.materialDiffuse Front $= (glColorOfColor col)++data VisObject a = VisObjects [VisObject a]+ | Trans (V3 a) (VisObject a)+ | RotQuat (Quaternion a) (VisObject a)+ | RotDcm (M33 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) GlossColor.Color+ | Box (a,a,a) Flavour GlossColor.Color+ | Cube a Flavour GlossColor.Color+ | Sphere a Flavour GlossColor.Color+ | Ellipsoid (a,a,a) Flavour GlossColor.Color+ | Line [V3 a] GlossColor.Color+ | Line' [(V3 a,GlossColor.Color)]+ | Arrow (a,a) (V3 a) GlossColor.Color+ | Axes (a,a)+ | Plane (V3 a) GlossColor.Color GlossColor.Color+ | Triangle (V3 a) (V3 a) (V3 a) GlossColor.Color+ | Quad (V3 a) (V3 a) (V3 a) (V3 a) GlossColor.Color+ | Text3d String (V3 a) BitmapFont GlossColor.Color+ | Text2d String (a,a) BitmapFont GlossColor.Color+ | Points [V3 a] (Maybe GLfloat) GlossColor.Color+ deriving (Generic, Functor)++instance S.Serialize Flavour where+ put Solid = S.put False+ put Wireframe = S.put True+ get = do+ b <- S.get+ return $ case b of+ False -> Solid+ True -> Wireframe+instance S.Serialize BitmapFont where+ put Fixed8By13 = S.put (0 :: Word8)+ put Fixed9By15 = S.put (1 :: Word8)+ put TimesRoman10 = S.put (2 :: Word8)+ put TimesRoman24 = S.put (3 :: Word8)+ put Helvetica10 = S.put (4 :: Word8)+ put Helvetica12 = S.put (5 :: Word8)+ put Helvetica18 = S.put (6 :: Word8)+ get = do+ k <- S.get :: S.Get Word8+ return $ case k of+ 0 -> Fixed8By13+ 1 -> Fixed9By15+ 2 -> TimesRoman10+ 3 -> TimesRoman24+ 4 -> Helvetica10+ 5 -> Helvetica12+ 6 -> Helvetica18+ _ -> error $ "deserializing BitmapFont got bad value (" ++ show k ++ ")"++instance S.Serialize (GlossColor.Color) where+ get = do+ (x,y,z,a) <- S.get+ return $ GlossColor.makeColor x y z a+ put x = S.put (GlossColor.rgbaOfColor x)+instance S.Serialize (GLfloat) where+ get = fmap CFloat S.get+ put (CFloat x) = S.put x++instance S.Serialize a => S.Serialize (Quaternion a)+instance S.Serialize a => S.Serialize (V3 a)+instance S.Serialize a => S.Serialize (VisObject a)++setPerspectiveMode :: IO ()+setPerspectiveMode = do+ (_, Size w h) <- GLUT.get GLUT.viewport+ GLUT.matrixMode $= Projection+ GLUT.loadIdentity+ GLUT.perspective 40 (fromIntegral w / fromIntegral h) 0.1 1000+ GLUT.matrixMode $= Modelview 0++drawObjects :: VisObject GLdouble -> IO ()+drawObjects objects = do+ setPerspectiveMode+ drawObject objects++drawObject :: VisObject GLdouble -> IO ()+-- list of objects+drawObject (VisObjects xs) = mapM_ drawObject xs++-- list of objects+drawObject (Trans (V3 x y z) visobj) =+ GLUT.preservingMatrix $ do+ GLUT.translate (Vector3 x y z :: Vector3 GLdouble)+ drawObject visobj++drawObject (RotQuat (Quaternion q0 (V3 q1 q2 q3)) visobj) =+ GLUT.preservingMatrix $ do+ GLUT.rotate (2 * acos q0 *180/pi :: GLdouble) (Vector3 q1 q2 q3)+ drawObject visobj++drawObject (RotDcm dcm visobject) =+ drawObject (RotQuat (quatOfDcm dcm) visobject)++drawObject (RotEulerRad euler visobj) =+ drawObject $ RotEulerDeg (fmap ((180/pi)*) euler) visobj++drawObject (RotEulerDeg (Euler yaw pitch roll) visobj) =+ GLUT.preservingMatrix $ do+ GLUT.rotate yaw (Vector3 0 0 1)+ GLUT.rotate pitch (Vector3 0 1 0)+ GLUT.rotate roll (Vector3 1 0 0)+ drawObject visobj++drawObject (Scale (sx,sy,sz) visobj) =+ GLUT.preservingMatrix $ do+ GLUT.normalize $= Enabled+ GLUT.scale sx sy sz+ drawObject visobj+ GLUT.normalize $= Disabled++-- triangle+drawObject (Triangle (V3 x0 y0 z0) (V3 x1 y1 z1) (V3 x2 y2 z2) col) =+ GLUT.preservingMatrix $ do+ setMaterialDiffuse col+ setColor col+ glBegin gl_TRIANGLES+ glVertex3d x0 y0 z0+ glVertex3d x1 y1 z1+ glVertex3d x2 y2 z2+ glEnd+ +-- quad+drawObject (Quad (V3 x0 y0 z0) (V3 x1 y1 z1) (V3 x2 y2 z2) (V3 x3 y3 z3) col) =+ GLUT.preservingMatrix $ do+ GLUT.lighting $= Disabled+ setColor col+ glBegin gl_QUADS+ glVertex3d x0 y0 z0+ glVertex3d x1 y1 z1+ glVertex3d x2 y2 z2+ glVertex3d x3 y3 z3+ glEnd+ GLUT.lighting $= Enabled++-- cylinder+drawObject (Cylinder (height,radius) col) =+ GLUT.preservingMatrix $ do+ setMaterialDiffuse col+ setColor col+ + -- GLUT.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 (Sphere r flav col) =+ GLUT.preservingMatrix $ do+ setMaterialDiffuse col+ setColor col+ GLUT.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 (Box (dx,dy,dz) flav col) = drawObject $ Scale (dx,dy,dz) $ Cube 1 flav col++drawObject (Cube r flav col) =+ GLUT.preservingMatrix $ do+ setMaterialDiffuse col+ setColor col+ GLUT.renderObject flav (GLUT.Cube (realToFrac r))++-- line+drawObject (Line path col) =+ GLUT.preservingMatrix $ do+ GLUT.lighting $= Disabled+ setColor col+ GLUT.renderPrimitive LineStrip $ mapM_ (\(V3 x' y' z') -> GLUT.vertex $ Vertex3 x' y' z') path+ GLUT.lighting $= Enabled++-- line where you set the color at each vertex+drawObject (Line' pathcols) =+ GLUT.preservingMatrix $ do+ GLUT.lighting $= Disabled+ + glBegin gl_LINE_STRIP+ let f (xyz, col) = do+ let V3 x y z = fmap realToFrac xyz+ setMaterialDiffuse col+ setColor col+ glVertex3f x y z+ mapM_ f pathcols+ glEnd+ GLUT.lighting $= Enabled++-- plane+drawObject (Plane (V3 x y z) col1 col2) =+ GLUT.preservingMatrix $ do+ 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+ GLUT.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+ let drawWithEps eps' = do+ mapM_ drawObject $ concat [[ Line [ V3 (-r) y0 eps'+ , V3 r y0 eps'+ ] col1+ , Line [ V3 x0 (-r) eps',+ V3 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 (Arrow (size, aspectRatio) (V3 x y z) col) =+ GLUT.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+ + GLUT.rotate rotAngle rotAxis+ + -- cylinder+ drawObject $ Cylinder (cylinderHeight, cylinderRadius) col+ -- cone+ setMaterialDiffuse col+ setColor col+ GLUT.translate (Vector3 0 0 cylinderHeight :: Vector3 GLdouble)+ GLUT.renderObject Solid (GLUT.Cone coneRadius coneHeight numSlices numStacks)++drawObject (Axes (size, aspectRatio)) = GLUT.preservingMatrix $ do+ let xAxis = Arrow (size, aspectRatio) (V3 1 0 0) (GlossColor.makeColor 1 0 0 1)+ yAxis = Arrow (size, aspectRatio) (V3 0 1 0) (GlossColor.makeColor 0 1 0 1)+ zAxis = Arrow (size, aspectRatio) (V3 0 0 1) (GlossColor.makeColor 0 0 1 1)+ drawObject $ VisObjects [xAxis, yAxis, zAxis]++drawObject (Text3d string (V3 x y z) font col) = GLUT.preservingMatrix $ do+ GLUT.lighting $= Disabled+ setColor col+ glRasterPos3d x y z+ GLUT.renderString font string+ GLUT.lighting $= Enabled++drawObject (Text2d string (x,y) font col) = GLUT.preservingMatrix $ do+ GLUT.lighting $= Disabled+ setColor col++ GLUT.matrixMode $= Projection+ GLUT.loadIdentity++ (_, Size w h) <- GLUT.get GLUT.viewport+ GLUT.ortho2D 0 (fromIntegral w) 0 (fromIntegral h)+ GLUT.matrixMode $= Modelview 0+ GLUT.loadIdentity++ glRasterPos2d x y+ GLUT.renderString font string++ setPerspectiveMode+ GLUT.lighting $= Enabled++drawObject (Vis.VisObject.Points xyzs ps col) =+ GLUT.preservingMatrix $ do+ GLUT.lighting $= Disabled+ setColor col+ s' <- GLUT.get GLUT.pointSize+ when (isJust ps) $ GLUT.pointSize $= (fromJust ps)+ GLUT.renderPrimitive GLUT.Points $+ mapM_ (\(V3 x' y' z') -> GLUT.vertex $ Vertex3 x' y' z') xyzs+ GLUT.pointSize $= s'+ GLUT.lighting $= Enabled+