diff --git a/not-gloss.cabal b/not-gloss.cabal --- a/not-gloss.cabal +++ b/not-gloss.cabal @@ -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 diff --git a/src/Vis.hs b/src/Vis.hs --- a/src/Vis.hs +++ b/src/Vis.hs @@ -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 diff --git a/src/Vis/Interface.hs b/src/Vis/Interface.hs --- a/src/Vis/Interface.hs +++ b/src/Vis/Interface.hs @@ -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 diff --git a/src/Vis/Vis.hs b/src/Vis/Vis.hs --- a/src/Vis/Vis.hs +++ b/src/Vis/Vis.hs @@ -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