Vis (empty) → 0.7.7.0
raw patch · 10 files changed
+1507/−0 lines, 10 filesdep +GLUTdep +OpenGLdep +OpenGLRawsetup-changed
Dependencies added: GLUT, OpenGL, OpenGLRaw, SpatialMath, base, binary, bmp, bytestring, time, vector, vector-binary-instances
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Vis.cabal +44/−0
- changelog.txt +2/−0
- 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
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Greg Horn++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Greg Horn nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Vis.cabal view
@@ -0,0 +1,44 @@+name: Vis+version: 0.7.7.0+stability: Experimental+synopsis: Painless 3D graphics, no affiliation with gloss+description:{+This package is a fork of Greg Horn's not-gloss package.+The dependencies have been changed so that it builds with recent ghc versions.+}++extra-source-files: changelog.txt++license: BSD3+license-file: LICENSE+author: Greg Horn+maintainer: Scott N. Walck <walck@lvc.edu>+copyright: (c) Greg Horn 2012-2015+category: Graphics+build-type: Simple+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Vis+ Vis.Camera+ Vis.Interface+ Vis.Vis+ Vis.VisObject+ Vis.GlossColor+ build-depends: base >= 4.5 && < 5,+ GLUT >= 2.7.0 && < 2.8,+ OpenGL >= 3.0.3 && < 3.1,+ OpenGLRaw >= 3.3.4 && < 3.4,+ bytestring >= 0.11.4 && < 0.12,+ binary >= 0.8.9 && < 0.9,+ bmp >= 1.2.6 && < 1.3,+ SpatialMath >= 0.2.7 && < 0.3,+ vector >= 0.13.0 && < 0.14,+ time >= 1.11.1 && < 1.12,+ vector-binary-instances >= 0.2.5 && < 0.3+ default-language: Haskell2010++source-repository head+ type: git+ location: git://github.com/ghorn/not-gloss.git
+ changelog.txt view
@@ -0,0 +1,2 @@+0.7.7.0:+- initial fork of not-gloss-0.7.7.0
+ 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'