not-gloss 0.6.1.0 → 0.7.7.0
raw patch · 14 files changed
Files
- Vis.hs +0/−21
- Vis/Camera.hs +0/−97
- Vis/GlossColor.hs +0/−250
- Vis/Interface.hs +0/−134
- Vis/Vis.hs +0/−190
- Vis/VisObject.hs +0/−316
- changelog.txt +25/−0
- not-gloss.cabal +11/−4
- src/Vis.hs +45/−0
- src/Vis/Camera.hs +112/−0
- src/Vis/GlossColor.hs +250/−0
- src/Vis/Interface.hs +132/−0
- src/Vis/Vis.hs +455/−0
- src/Vis/VisObject.hs +435/−0
− Vis.hs
@@ -1,21 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--module Vis ( display- , animate- , simulate- , play- , animateIO- , simulateIO- , playIO- , VisObject(..)- , SpecialKey(..)- , BitmapFont(..)- , Flavour(..)- , module Vis.GlossColor- ) where--import Graphics.UI.GLUT ( SpecialKey(..), BitmapFont(..), Flavour(..) )--import Vis.Interface ( display, animate, simulate, play, animateIO, simulateIO, playIO )-import Vis.VisObject ( VisObject(..) )-import Vis.GlossColor
− 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,134 +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 ( vis )-import Vis.Camera ( makeCamera, Camera0(..), setCamera, cameraMotion, cameraKeyboardMouse )-import Vis.VisObject ( VisObject(..) )----- | draw a static image-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 =>- 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 =>- 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 = ()- 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 =>- 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 sizepos name ts state0 userDrawFun userSimFun =- simulateIO sizepos name ts state0 (return . userDrawFun) (\t -> return . (userSimFun t))---- | run a simulation impurely-simulateIO :: Real b =>- 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 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- 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 =>- 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)- -> (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 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------- | play a game impurely-playIO :: Real b =>- 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)- -> (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 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
@@ -1,190 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--module Vis.Vis ( 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 )---- user state and internal states-type FullState a = (a, Float)--myGlInit :: Maybe ((Int,Int), (Int,Int)) -> String -> IO ()-myGlInit sizepos progName = do- initialDisplayMode $= [ DoubleBuffered, RGBAMode, WithDepthBuffer ]-- Size x y <- get screenSize- putStrLn $ "screen resolution " ++ show x ++ "x" ++ show y- let intScale d i = round $ d*(realToFrac i :: Double)- x0 = intScale 0.3 x- xf = intScale 0.95 x- y0 = intScale 0.05 y- yf = intScale 0.95 y-- ((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- 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 =>- 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- -> (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 sizepos windowname ts x0 userSimFun userDraw userSetCamera- userKeyMouseCallback userMotionCallback userPassiveMotionCallback = do- -- init glut/scene- _ <- getArgsAndInitialize- - myGlInit sizepos windowname- - -- 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-
changelog.txt view
@@ -1,3 +1,28 @@+0.7.6.5:+- export LoadedObjModel data constructor++0.7.6.4:+- use matrix multiplication for DCM/quat rotations++0.7.6.3:+- support OpenGL 3++0.7.5.0:+- add z translation with middle mouse button++0.7.3.0:+- add object models++0.7.2.0:+- add option to set initial camera position++0.7.1.0:+- add an interface which makes a movie++0.7.0.0:+- pass in user options with Options type+- add an optional background color argument+ 0.6.0.0: - use spatial-math 0.2, which uses types from `linear` package
not-gloss.cabal view
@@ -1,5 +1,5 @@ name: not-gloss-version: 0.6.1.0+version: 0.7.7.0 stability: Experimental synopsis: Painless 3D graphics, no affiliation with gloss description:{@@ -20,12 +20,13 @@ license-file: LICENSE author: Greg Horn maintainer: gregmainland@gmail.com-copyright: (c) Greg Horn 2012-2014+copyright: (c) Greg Horn 2012-2015 category: Graphics build-type: Simple cabal-version: >=1.8 library+ hs-source-dirs: src exposed-modules: Vis Vis.Camera Vis.Interface@@ -38,8 +39,14 @@ build-depends: base >= 4.5 && < 5, GLUT >= 2.3.0, time >= 1.4.0,- OpenGLRaw >= 1.2.0,- spatial-math >= 0.2.0+ OpenGLRaw >= 3.1.0.0,+ OpenGL >= 3.0.0.1,+ spatial-math >= 0.2.1.2,+ vector,+ binary,+ vector-binary-instances > 0.2.1.0,+ bytestring,+ bmp ghc-options: -O2
+ src/Vis.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -Wall #-}++module Vis ( Options(..)+ , Antialiasing(..)+ , Camera0(..)+ , defaultOpts+ , display+ , animate+ , simulate+ , play+ , animateIO+ , simulateIO+ , playIO+ , visMovie+ , VisObject(..)+ , SpecialKey(..)+ , BitmapFont(..)+ , Flavour(..)+ , LoadedObjModel+ , loadObjModel+ , module Vis.GlossColor+ ) where++import Graphics.UI.GLUT ( SpecialKey(..), BitmapFont(..), Flavour(..) )++import Vis.Vis ( Options(..), Antialiasing(..), visMovie )+import Vis.Camera ( Camera0(..) )+import Vis.Interface ( display, animate, simulate, play, animateIO, simulateIO, playIO )+import Vis.VisObject ( VisObject(..), LoadedObjModel, loadObjModel )+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"+ , optInitialCamera = Nothing+ , optAntialiasing = Aliased+ }
+ src/Vis/Camera.hs view
@@ -0,0 +1,112 @@+{-# 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+ } deriving Show++data Camera = Camera { phi :: GLdouble+ , theta :: GLdouble+ , rho :: GLdouble+ , pos :: V3 GLdouble+ , ballX :: GLint+ , ballY :: GLint + , leftButton :: GLint+ , rightButton :: GLint+ , middleButton :: 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+ , middleButton = 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 mb) (Position x y) =+ Camera nextPhi nextTheta rho0' nextPos nextBallX nextBallY lb rb mb+ where+ deltaX+ | bx == -1 = 0+ | otherwise = fromIntegral (x - bx)+ deltaY+ | by == -1 = 0+ | otherwise = fromIntegral (y - by)+ deltaZ+ | 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)+ nextZ = z0 - 0.001*rho0'*deltaZ++ (nextPhi, nextTheta) = if lb == 1+ then (phi0' + deltaX, nextTheta')+ else (phi0', theta0')++ nextPos+ | rb == 1 = V3 nextX nextY z0+ | mb == 1 = V3 x0 y0 nextZ+ | otherwise = V3 x0 y0 z0++ nextBallX = x+ nextBallY = y++cameraKeyboardMouse :: Camera -> Key -> KeyState -> Camera+cameraKeyboardMouse camera key keyState =+ camera {rho = newRho, leftButton = lb, rightButton = rb, middleButton = mb, 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)+ (mb, reset2) = case (key, keyState) of (MouseButton MiddleButton, Down) -> (1, True)+ (MouseButton MiddleButton, Up) -> (0, False)+ _ -> (middleButton camera, False)+ + (bx,by) = if reset0 || reset1 || reset2 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,132 @@+{-# OPTIONS_GHC -Wall #-}++module Vis.Interface ( display+ , animate+ , animateIO+ , simulate+ , simulateIO+ , play+ , playIO+ ) where++import Data.Maybe ( fromMaybe )+import Graphics.UI.GLUT ( Key, KeyState, Position, Modifiers, Cursor(..) )++import Vis.Vis ( Options(..), vis )+import Vis.Camera ( Camera, Camera0(..), makeCamera, 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 (takes time since start as input)+ -> IO ()+animate opts userDrawFun = animateIO opts (return . userDrawFun)++-- | display an animation impurely+animateIO :: Real b =>+ Options -- ^ user options+ -> (Float -> IO (VisObject b)) -- ^ draw function (takes time since start as input)+ -> IO ()+animateIO opts userDrawFun =+ vis opts ts (userState0, cameraState0) simFun drawFun setCameraFun (Just kmCallback) (Just motionCallback) Nothing+ where+ ts = 0.01+ userState0 = ()+ cameraState0 = makeCamera $ fromMaybe defaultCamera (optInitialCamera opts)+ 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 :: ((), Camera) -> IO ()+ 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 time since start 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 time since start 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 $ fromMaybe defaultCamera (optInitialCamera opts)+ 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 time since start 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 time since start 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+++defaultCamera :: Camera0+defaultCamera =+ Camera0+ { phi0 = 60+ , theta0 = 20+ , rho0 = 7}
+ src/Vis/Vis.hs view
@@ -0,0 +1,455 @@+{-# OPTIONS_GHC -Wall #-}+{-# Language ScopedTypeVariables #-}++module Vis.Vis ( Options(..)+ , Antialiasing(..)+ , vis+ , visMovie+ , visMovieImmediately+ , FullState+ ) where++import Codec.BMP ( BMP, packRGBA32ToBMP32, writeBMP )+import Control.Concurrent ( MVar, readMVar, swapMVar, newMVar, takeMVar, putMVar, forkIO, threadDelay )+import Control.Monad ( unless, forever )+import qualified Data.ByteString.Unsafe as BS+import Data.Maybe ( fromMaybe )+import Data.IORef ( newIORef, readIORef, writeIORef )+import Data.Time.Clock ( getCurrentTime, diffUTCTime, addUTCTime )+import Data.Word ( Word8 )+import Foreign.Marshal.Alloc ( free )+import Foreign.Marshal.Array ( mallocArray )+import Foreign.Ptr ( Ptr, castPtr )+import Foreign.Storable ( sizeOf )+import qualified Graphics.UI.GLUT as GLUT+import Graphics.UI.GLUT ( Capability(..), ClearBuffer(..), Color4(..), ColorMaterialParameter(..)+ , ComparisonFunction(..), Cursor(..), DisplayMode(..), Face(..)+ , Key(..), KeyState(..), Light(..), Modifiers(..), Position(..)+ , ShadingModel(..), Size(..)+ , DisplayCallback, ReshapeCallback+ , ($=)+ )+import Graphics.GL+import Text.Printf ( printf )+import System.Exit ( exitSuccess )++import Vis.Camera ( Camera, Camera0(..), setCamera, makeCamera, cameraKeyboardMouse, cameraMotion )+import Vis.VisObject ( VisObject(..), drawObjects, setPerspectiveMode )+import qualified Vis.GlossColor as GC++-- | user state and internal states+type FullState a = (a, Float)++data Antialiasing =+ Aliased+ | Smoothed+ | Multisampled Int+ deriving (Eq, Show, Ord)++data Options =+ Options+ { optBackgroundColor :: Maybe GC.Color -- ^ optional background color+ , optWindowSize :: Maybe (Int,Int) -- ^ optional (x,y) window size in pixels+ , optWindowPosition :: Maybe (Int,Int) -- ^ optional (x,y) window origin in pixels+ , optWindowName :: String -- ^ window name+ , optInitialCamera :: Maybe Camera0 -- ^ initial camera position+ , optAntialiasing :: Antialiasing -- ^ which antialiasing strategy to use+ } deriving Show++myGlInit :: Options -> IO ()+myGlInit opts = do+ let displayMode = [ DoubleBuffered, RGBAMode, WithDepthBuffer ] +++ case optAntialiasing opts of+ Multisampled numSamples -> [ GLUT.Multisampling+ , GLUT.WithSamplesPerPixel numSamples+ ]+ _ -> []+ GLUT.initialDisplayMode $= displayMode++ Size x y <- GLUT.get GLUT.screenSize+ 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)++ case optAntialiasing opts of+ Aliased -> do+ GLUT.lineSmooth $= Disabled+ GLUT.pointSmooth $= Disabled+ GLUT.multisample $= Disabled+ Smoothed -> do+ GLUT.hint GLUT.LineSmooth $= GLUT.Nicest+ GLUT.hint GLUT.PointSmooth $= GLUT.Nicest+ GLUT.lineSmooth $= Enabled+ GLUT.pointSmooth $= Enabled+ GLUT.multisample $= Disabled+ Multisampled _ -> do+ GLUT.lineSmooth $= Disabled+ GLUT.pointSmooth $= Disabled+ GLUT.multisample $= Enabled++ 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 -- todo: why not just block?+ 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+++++movieSimThread :: [VisObject a] -> MVar ([VisObject a], Camera) -> MVar Bool -> Double -> IO ()+movieSimThread objects0 stateMVar visReadyMVar ts = do+ let waitUntilDisplayIsReady :: IO ()+ waitUntilDisplayIsReady = do -- todo: why not just block?+ 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))++ if usRemaining <= 0+ -- slept for long enough, do a sim iteration+ then do+ lastTimeRef $= addUTCTime (realToFrac ts) lastTime++ let getNextState = do+ state <- readMVar stateMVar+ let next = case state of+ (_:xs, cs) -> (xs, cs)+ ([], cs) -> (objects0, cs)+ return next+ putState x = swapMVar stateMVar x++ nextState <- getNextState+ _ <- nextState `seq` putState nextState++ GLUT.postRedisplay Nothing++ -- need to sleep longer+ else threadDelay usRemaining++-- | Make a series of images, one from each 'VisObject'.+-- When 'visMovie' is executed a window pops up and loops the animation+-- until you are happy with the camera angle.+-- Hit spacebar and the images will be created and saved to disk.+visMovie+ :: forall b+ . Real b+ => Options -- ^ user options+ -> (Int -> FilePath) -- ^ where to write the bitmaps+ -> Double -- ^ sample time+ -> [VisObject b] -- ^ movie to draw+ -> Maybe Cursor -- ^ optional cursor+ -> IO ()+visMovie = visMovie' False++-- | Make a series of images, one from each 'VisObject'.+-- When 'visMovieImmediately' is executed a window is opened and without+-- waiting the images are created and saved to disk.+visMovieImmediately+ :: forall b+ . Real b+ => Options -- ^ user options+ -> (Int -> FilePath) -- ^ where to write the bitmaps+ -> Double -- ^ sample time+ -> [VisObject b] -- ^ movie to draw+ -> Maybe Cursor -- ^ optional cursor+ -> IO ()+visMovieImmediately = visMovie' True++visMovie'+ :: forall b+ . Real b+ => Bool -- ^ start immediately+ -> Options -- ^ user options+ -> (Int -> FilePath) -- ^ where to write the bitmaps+ -> Double -- ^ sample time+ -> [VisObject b] -- ^ movie to draw+ -> Maybe Cursor -- ^ optional cursor+ -> IO ()+visMovie' startImmediately opts toFilename ts objectsToDraw maybeCursor = do+ -- init glut/scene+ _ <- GLUT.getArgsAndInitialize++ myGlInit opts++ let defaultCam =+ Camera0 { phi0 = 60+ , theta0 = 20+ , rho0 = 7}+ cameraState0 = makeCamera $ fromMaybe defaultCam (optInitialCamera opts)++ -- create internal state+ areWeDrawingRef <- newIORef False+ stateMVar <- newMVar (objectsToDraw, cameraState0)+ visReadyMVar <- newMVar startImmediately++ -- start sim thread+ _ <- forkIO $ movieSimThread objectsToDraw stateMVar visReadyMVar ts++ -- setup the callbacks+ let makePictures :: VisObject b -> Camera -> IO ()+ makePictures visobj cam = do+ GLUT.clear [ ColorBuffer, DepthBuffer ]++ -- draw the scene+ GLUT.preservingMatrix $ do+ setCamera cam+ drawObjects $ (fmap realToFrac) visobj+ case maybeCursor of+ Nothing -> return ()+ Just cursor -> GLUT.cursor $= cursor++ GLUT.flush+ GLUT.swapBuffers+ _ <- swapMVar visReadyMVar True+ GLUT.postRedisplay Nothing++ screenShot :: Int -> Camera -> (VisObject b, Int) -> IO ()+ screenShot n camera (visobj, imageNumber) = do+ -- todo: are width/height reversed?+ size@(Size width height) <- GLUT.get GLUT.windowSize+ let pos = Position 0 0+ ubytePtr <- mallocArray (fromIntegral (4*width*height)) :: IO (Ptr GLubyte)+ let pixelData = GLUT.PixelData GLUT.RGBA GLUT.UnsignedByte ubytePtr+ makePictures visobj camera+ -- "glFinish" will do the job, but it may be overkill.+ -- "swapBuffers" is probably good enough.+ -- http://stackoverflow.com/questions/2143240/opengl-glflush-vs-glfinish+ -- We just need to make sure that readPixels will do the right thing+ GLUT.finish+ GLUT.readPixels pos size pixelData+ let wordPtr :: Ptr Word8+ wordPtr+ | sizeOf (0 :: GLubyte) == sizeOf (0 :: Word8) = castPtr ubytePtr+ | otherwise = error "GLubyte size /= Word8 size"++ bs <- BS.unsafePackCStringFinalizer+ wordPtr (fromIntegral (4*width*height)) (free ubytePtr)+ let bmp :: BMP+ bmp = packRGBA32ToBMP32 (fromIntegral width) (fromIntegral height) bs++ let filename = toFilename imageNumber+ percent :: Double+ percent = 100 * fromIntegral imageNumber / fromIntegral n+ printf "writing \"%s\" (%d / %d == %6.2f %%) ...\n" filename imageNumber n percent+ writeBMP filename bmp++ drawFun = do+ areWeDrawing <- readIORef areWeDrawingRef+ (state,cam) <- readMVar stateMVar+ if areWeDrawing+ then do let n = length objectsToDraw+ state' <- takeMVar stateMVar+ mapM_ (screenShot n cam) (zip objectsToDraw [0..])+ putStrLn "finished writing files"+ putStrLn "you might want to try some command like:"+ putStrLn "\"ffmpeg -framerate 50 -i data/movie.%03d.bmp -c:v libx264 -r 30 -pix_fmt yuv420p out.mp4\""+ putMVar stateMVar state'++ writeIORef areWeDrawingRef False+ else do let visobj = case (state, objectsToDraw) of+ (y:_, _) -> y -- draw head object+ ([], y:_) -> y -- empty state so just draw first object+ ([], []) -> VisObjects [] -- nothing available+ makePictures visobj cam++ exitOverride k0 k1 _k2 _k3 = case (k0,k1) of+ -- ESC button exits the program+ (Char '\27', Down) -> exitSuccess+ -- space bar starts screenshots+ (Char ' ', Down) -> writeIORef areWeDrawingRef True+ _ -> do+ (state0', cs) <- takeMVar stateMVar+ putMVar stateMVar (state0', cameraKeyboardMouse cs k0 k1)+ GLUT.postRedisplay Nothing++ motionCallback' pos = do+ (state0', cs) <- takeMVar stateMVar+ putMVar stateMVar (state0', cameraMotion cs pos)+ GLUT.postRedisplay Nothing++-- passiveMotionCallback' pos = case userPassiveMotionCallback of+-- Nothing -> return ()+-- Just cb -> do+-- (state0', cs) <- takeMVar stateMVar+-- putMVar stateMVar (cb state0' pos, cs)+-- GLUT.postRedisplay Nothing++ GLUT.displayCallback $= drawFun+ GLUT.reshapeCallback $= Just reshape+ GLUT.keyboardMouseCallback $= Just exitOverride+ GLUT.motionCallback $= Just motionCallback'+-- GLUT.passiveMotionCallback $= Just passiveMotionCallback'++ -- start main loop+ GLUT.mainLoop
+ src/Vis/VisObject.hs view
@@ -0,0 +1,435 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# Language StandaloneDeriving #-}+{-# Language DeriveFunctor #-}+{-# Language DeriveGeneric #-}+{-# Language TypeSynonymInstances #-}++module Vis.VisObject ( VisObject(..)+ , drawObjects+ , LoadedObjModel(..)+ , loadObjModel+ , setPerspectiveMode+ ) where++import GHC.Generics ( Generic )++import Control.Monad ( when )+import qualified Data.Binary as B+import qualified Data.Foldable as F+import Data.Maybe ( fromJust, isJust )+import Data.Vector.Binary ()+import qualified Data.Vector.Storable as VS+import Data.Word ( Word8 )+import Graphics.GL+import qualified Graphics.Rendering.OpenGL as GL+import qualified Graphics.UI.GLUT as GLUT+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 (Maybe a) [V3 a] GlossColor.Color+ | Line' (Maybe a) [(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+ | ObjModel LoadedObjModel GlossColor.Color+ deriving (Generic, Functor)++data LoadedObjModel = LoadedObjModel (VS.Vector Double) (VS.Vector Double) Int deriving (Generic)++instance B.Binary LoadedObjModel++toFlavour :: Bool -> Flavour+toFlavour False = Solid+toFlavour True = Wireframe++fromFlavour :: Flavour -> Bool+fromFlavour Solid = False+fromFlavour Wireframe = True++instance B.Binary Flavour where+ put = B.put . fromFlavour+ get = fmap toFlavour B.get+++fromBitmapFont :: BitmapFont -> Word8+fromBitmapFont Fixed8By13 = 0 :: Word8+fromBitmapFont Fixed9By15 = 1 :: Word8+fromBitmapFont TimesRoman10 = 2 :: Word8+fromBitmapFont TimesRoman24 = 3 :: Word8+fromBitmapFont Helvetica10 = 4 :: Word8+fromBitmapFont Helvetica12 = 5 :: Word8+fromBitmapFont Helvetica18 = 6 :: Word8++toBitmapFont :: Word8 -> BitmapFont+toBitmapFont 0 = Fixed8By13+toBitmapFont 1 = Fixed9By15+toBitmapFont 2 = TimesRoman10+toBitmapFont 3 = TimesRoman24+toBitmapFont 4 = Helvetica10+toBitmapFont 5 = Helvetica12+toBitmapFont 6 = Helvetica18+toBitmapFont k = error $ "deserializing BitmapFont got bad value (" ++ show k ++ ")"++instance B.Binary BitmapFont where+ put = B.put . fromBitmapFont+ get = fmap toBitmapFont B.get+++fromColor :: GlossColor.Color -> (Float,Float,Float,Float)+fromColor = GlossColor.rgbaOfColor++toColor :: (Float,Float,Float,Float) -> GlossColor.Color+toColor (r,g,b,a) = GlossColor.makeColor r g b a++instance B.Binary (GlossColor.Color) where+ put = B.put . fromColor+ get = fmap toColor B.get+++instance B.Binary a => B.Binary (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 quat visobj) = drawObject (RotDcm (dcmOfQuat quat) visobj)++drawObject (RotDcm (V3 (V3 m00 m01 m02) (V3 m10 m11 m12) (V3 m20 m21 m22)) visobject) =+ GLUT.preservingMatrix $ do+ mat <- GLUT.newMatrix GLUT.ColumnMajor+ [ m00, m01, m02, 0+ , m10, m11, m12, 0+ , m20, m21, m22, 0+ , 0, 0, 0, 1+ ]+ :: IO (GLUT.GLmatrix GLdouble)+ GLUT.multMatrix mat+ drawObject 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 width path col) =+ GLUT.preservingMatrix $ do+ GLUT.lighting $= Disabled+ setColor col+ lineWidth0 <- GLUT.get GLUT.lineWidth+ case width of+ Just w -> GLUT.lineWidth $= realToFrac w+ Nothing -> return ()++ GLUT.renderPrimitive LineStrip $ mapM_ (\(V3 x' y' z') -> GLUT.vertex $ Vertex3 x' y' z') path+ GLUT.lineWidth $= lineWidth0+ GLUT.lighting $= Enabled++-- line where you set the color at each vertex+drawObject (Line' width pathcols) =+ GLUT.preservingMatrix $ do+ GLUT.lighting $= Disabled++ lineWidth0 <- GLUT.get GLUT.lineWidth+ case width of+ Just w -> GLUT.lineWidth $= realToFrac w+ Nothing -> return ()++ 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.lineWidth $= lineWidth0+ 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 Nothing+ [ V3 (-r) y0 eps'+ , V3 r y0 eps'+ ] col1+ , Line Nothing+ [ 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++drawObject (Vis.VisObject.ObjModel (LoadedObjModel vvec nvec numVerts) col) =+ GLUT.preservingMatrix $ do+ setMaterialDiffuse col+ setColor col++ -- enable vertex/normal arrays+ -- todo: Should this be done every time?+ -- Either enable at the start, or push/pop to preserve user attributes+ GL.clientState GL.VertexArray $= GL.Enabled+ GL.clientState GL.NormalArray $= GL.Enabled++ -- set the vertex and normal arrays+ let va = GL.VertexArrayDescriptor 3 GL.Double 0+ na = GL.VertexArrayDescriptor 3 GL.Double 0+ VS.unsafeWith vvec $ \vptr -> GL.arrayPointer GL.VertexArray $= va vptr+ VS.unsafeWith nvec $ \nptr -> GL.arrayPointer GL.NormalArray $= na nptr+ -- draw the triangles+ GL.drawArrays GL.Triangles 0 (fromIntegral numVerts)++ -- disable vertex/normal arrays+ GL.clientState GL.VertexArray $= GL.Disabled+ GL.clientState GL.NormalArray $= GL.Disabled++-- | turn a list of vertex/normal tuples into vertex/normal arrays+loadObjModel :: F.Foldable f => f (V3 Double, V3 Double) -> LoadedObjModel+loadObjModel vns = LoadedObjModel (VS.fromList vs) (VS.fromList ns) n+ where+ vs = F.concatMap (\(V3 x y z) -> [x,y,z]) vs'+ ns = F.concatMap (\(V3 x y z) -> [x,y,z]) ns'+ (vs',ns') = unzip $ F.toList vns+ n = length vs'