not-gloss 0.7.0.2 → 0.7.1.0
raw patch · 4 files changed
+210/−23 lines, 4 filesdep +bmpdep +bytestring
Dependencies added: bmp, bytestring
Files
- not-gloss.cabal +4/−2
- src/Vis.hs +2/−1
- src/Vis/Interface.hs +2/−1
- src/Vis/Vis.hs +202/−19
not-gloss.cabal view
@@ -1,5 +1,5 @@ name: not-gloss-version: 0.7.0.2+version: 0.7.1.0 stability: Experimental synopsis: Painless 3D graphics, no affiliation with gloss description:{@@ -42,7 +42,9 @@ OpenGLRaw >= 2.3.0, spatial-math >= 0.2.1.2, cereal,- binary+ binary,+ bytestring,+ bmp ghc-options: -O2
src/Vis.hs view
@@ -9,6 +9,7 @@ , animateIO , simulateIO , playIO+ , visMovie , VisObject(..) , SpecialKey(..) , BitmapFont(..)@@ -18,7 +19,7 @@ import Graphics.UI.GLUT ( SpecialKey(..), BitmapFont(..), Flavour(..) ) -import Vis.Vis ( Options(..) )+import Vis.Vis ( Options(..), visMovie ) import Vis.Interface ( display, animate, simulate, play, animateIO, simulateIO, playIO ) import Vis.VisObject ( VisObject(..) ) import Vis.GlossColor
src/Vis/Interface.hs view
@@ -12,7 +12,7 @@ import Graphics.UI.GLUT ( Key, KeyState, Position, Modifiers, Cursor(..) ) import Vis.Vis ( Options, vis )-import Vis.Camera ( makeCamera, Camera0(..), setCamera, cameraMotion, cameraKeyboardMouse )+import Vis.Camera ( Camera, Camera0(..), makeCamera, setCamera, cameraMotion, cameraKeyboardMouse ) import Vis.VisObject ( VisObject(..) ) -- | draw a static image@@ -48,6 +48,7 @@ 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
src/Vis/Vis.hs view
@@ -1,16 +1,25 @@ {-# OPTIONS_GHC -Wall #-}+{-# Language ScopedTypeVariables #-} module Vis.Vis ( Options(..) , vis+ , visMovie , FullState ) where -import Data.Maybe ( fromMaybe )-import Data.IORef ( newIORef )-import System.Exit ( exitSuccess )-import Data.Time.Clock ( getCurrentTime, diffUTCTime, addUTCTime )+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(..)@@ -18,9 +27,12 @@ , DisplayCallback, ReshapeCallback , ($=) )-import qualified Graphics.UI.GLUT as GLUT-import Graphics.Rendering.OpenGL.Raw+import Graphics.Rendering.OpenGL.Raw ( GLubyte, glEnable, glBlendFunc+ , gl_BLEND, gl_SRC_ALPHA, gl_ONE_MINUS_SRC_ALPHA )+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 @@ -68,7 +80,7 @@ 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@@ -80,12 +92,12 @@ 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@@ -119,9 +131,9 @@ userKeyMouseCallback userMotionCallback userPassiveMotionCallback = do -- init glut/scene _ <- GLUT.getArgsAndInitialize- + myGlInit opts- + -- create internal state let fullState0 = (x0, 0) stateMVar <- newMVar fullState0@@ -129,7 +141,7 @@ -- start sim thread _ <- forkIO $ simThread stateMVar visReadyMVar userSimFun ts- + -- setup the callbacks let makePictures x = do (visobs,cursor') <- userDraw x@@ -137,7 +149,7 @@ case cursor' of Nothing -> return () Just cursor'' -> GLUT.cursor $= cursor'' - setCamera = do+ setCamera' = do (state,_) <- readMVar stateMVar userSetCamera state @@ -165,7 +177,7 @@ putMVar stateMVar (cb state0' pos, ts') GLUT.postRedisplay Nothing - GLUT.displayCallback $= drawScene stateMVar visReadyMVar setCamera makePictures+ GLUT.displayCallback $= drawScene stateMVar visReadyMVar setCamera' makePictures GLUT.reshapeCallback $= Just reshape GLUT.keyboardMouseCallback $= Just exitOverride GLUT.motionCallback $= Just motionCallback'@@ -177,14 +189,14 @@ simThread :: MVar (FullState a) -> MVar Bool -> (FullState a -> IO a) -> Double -> IO () simThread stateMVar visReadyMVar userSimFun ts = do let waitUntilDisplayIsReady :: IO ()- waitUntilDisplayIsReady = do + waitUntilDisplayIsReady = do -- todo: why not just block? visReady <- readMVar visReadyMVar unless visReady $ do threadDelay 10000 waitUntilDisplayIsReady- + waitUntilDisplayIsReady- + t0 <- getCurrentTime lastTimeRef <- newIORef t0 @@ -195,7 +207,7 @@ 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@@ -210,6 +222,177 @@ _ <- 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+++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 opts toFilename ts objectsToDraw maybeCursor = do+ -- init glut/scene+ _ <- GLUT.getArgsAndInitialize++ myGlInit opts++ let cameraState0 =+ makeCamera $+ Camera0 { phi0 = 60+ , theta0 = 20+ , rho0 = 7}++ -- create internal state+ areWeDrawingRef <- newIORef False+ stateMVar <- newMVar (objectsToDraw, cameraState0)+ visReadyMVar <- newMVar False++ -- 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+ printf "writing \"%s\" (%d / %d) ...\n" filename imageNumber n+ 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 20 -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