{-# 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 (Antialiasing -> Antialiasing -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Antialiasing -> Antialiasing -> Bool
$c/= :: Antialiasing -> Antialiasing -> Bool
== :: Antialiasing -> Antialiasing -> Bool
$c== :: Antialiasing -> Antialiasing -> Bool
Eq, Int -> Antialiasing -> ShowS
[Antialiasing] -> ShowS
Antialiasing -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Antialiasing] -> ShowS
$cshowList :: [Antialiasing] -> ShowS
show :: Antialiasing -> String
$cshow :: Antialiasing -> String
showsPrec :: Int -> Antialiasing -> ShowS
$cshowsPrec :: Int -> Antialiasing -> ShowS
Show, Eq Antialiasing
Antialiasing -> Antialiasing -> Bool
Antialiasing -> Antialiasing -> Ordering
Antialiasing -> Antialiasing -> Antialiasing
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Antialiasing -> Antialiasing -> Antialiasing
$cmin :: Antialiasing -> Antialiasing -> Antialiasing
max :: Antialiasing -> Antialiasing -> Antialiasing
$cmax :: Antialiasing -> Antialiasing -> Antialiasing
>= :: Antialiasing -> Antialiasing -> Bool
$c>= :: Antialiasing -> Antialiasing -> Bool
> :: Antialiasing -> Antialiasing -> Bool
$c> :: Antialiasing -> Antialiasing -> Bool
<= :: Antialiasing -> Antialiasing -> Bool
$c<= :: Antialiasing -> Antialiasing -> Bool
< :: Antialiasing -> Antialiasing -> Bool
$c< :: Antialiasing -> Antialiasing -> Bool
compare :: Antialiasing -> Antialiasing -> Ordering
$ccompare :: Antialiasing -> Antialiasing -> Ordering
Ord)

data Options =
  Options
  { Options -> Maybe Color
optBackgroundColor :: Maybe GC.Color -- ^ optional background color
  , Options -> Maybe (Int, Int)
optWindowSize :: Maybe (Int,Int) -- ^ optional (x,y) window size in pixels
  , Options -> Maybe (Int, Int)
optWindowPosition :: Maybe (Int,Int) -- ^ optional (x,y) window origin in pixels
  , Options -> String
optWindowName :: String -- ^ window name
  , Options -> Maybe Camera0
optInitialCamera :: Maybe Camera0 -- ^ initial camera position
  , Options -> Antialiasing
optAntialiasing :: Antialiasing -- ^ which antialiasing strategy to use
  } deriving Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show

myGlInit :: Options -> IO ()
myGlInit :: Options -> IO ()
myGlInit Options
opts = do
  let displayMode :: [DisplayMode]
displayMode = [ DisplayMode
DoubleBuffered, DisplayMode
RGBAMode, DisplayMode
WithDepthBuffer ] forall a. [a] -> [a] -> [a]
++
        case Options -> Antialiasing
optAntialiasing Options
opts of
          Multisampled Int
numSamples -> [ DisplayMode
GLUT.Multisampling
                                     , Int -> DisplayMode
GLUT.WithSamplesPerPixel Int
numSamples
                                     ]
          Antialiasing
_ -> []
  StateVar [DisplayMode]
GLUT.initialDisplayMode forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= [DisplayMode]
displayMode

  Size GLint
x GLint
y <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
GLUT.get GettableStateVar Size
GLUT.screenSize
  let intScale :: Double -> a -> b
intScale Double
d a
i = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
dforall a. Num a => a -> a -> a
*(forall a b. (Real a, Fractional b) => a -> b
realToFrac a
i :: Double)
      x0 :: Int
x0 = forall {b} {a}. (Integral b, Real a) => Double -> a -> b
intScale Double
0.3 GLint
x
      xf :: Int
xf = forall {b} {a}. (Integral b, Real a) => Double -> a -> b
intScale Double
0.95 GLint
x
      y0 :: Int
y0 = forall {b} {a}. (Integral b, Real a) => Double -> a -> b
intScale Double
0.05 GLint
y
      yf :: Int
yf = forall {b} {a}. (Integral b, Real a) => Double -> a -> b
intScale Double
0.95 GLint
y

      (Int
xsize, Int
ysize) = forall a. a -> Maybe a -> a
fromMaybe (Int
xf forall a. Num a => a -> a -> a
- Int
x0, Int
yf forall a. Num a => a -> a -> a
- Int
y0) (Options -> Maybe (Int, Int)
optWindowSize Options
opts)
      (Int
xpos, Int
ypos) = forall a. a -> Maybe a -> a
fromMaybe (Int
x0,Int
y0) (Options -> Maybe (Int, Int)
optWindowPosition Options
opts)

  StateVar Size
GLUT.initialWindowSize forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLint -> GLint -> Size
Size (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
xsize) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ysize)
  StateVar Position
GLUT.initialWindowPosition forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLint -> GLint -> Position
Position (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
xpos) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ypos)
  Window
_ <- forall (m :: * -> *). MonadIO m => String -> m Window
GLUT.createWindow (Options -> String
optWindowName Options
opts)

  case Options -> Maybe Color
optBackgroundColor Options
opts of
    Maybe Color
Nothing  -> StateVar (Color4 GLfloat)
GLUT.clearColor forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> a -> a -> a -> Color4 a
Color4 GLfloat
0 GLfloat
0 GLfloat
0 GLfloat
0
    Just Color
col -> StateVar (Color4 GLfloat)
GLUT.clearColor forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> a -> a -> a -> Color4 a
Color4 (forall a b. (Real a, Fractional b) => a -> b
realToFrac GLfloat
r) (forall a b. (Real a, Fractional b) => a -> b
realToFrac GLfloat
g) (forall a b. (Real a, Fractional b) => a -> b
realToFrac GLfloat
b) (forall a b. (Real a, Fractional b) => a -> b
realToFrac GLfloat
a)
      where
        (GLfloat
r,GLfloat
g,GLfloat
b,GLfloat
a) = Color -> (GLfloat, GLfloat, GLfloat, GLfloat)
GC.rgbaOfColor Color
col
  StateVar ShadingModel
GLUT.shadeModel forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= ShadingModel
Smooth
  StateVar (Maybe ComparisonFunction)
GLUT.depthFunc forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just ComparisonFunction
Less
  StateVar Capability
GLUT.lighting forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
  Light -> StateVar Capability
GLUT.light (GLint -> Light
Light GLint
0) forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
  Light -> StateVar (Color4 GLfloat)
GLUT.ambient (GLint -> Light
Light GLint
0) forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> a -> a -> a -> Color4 a
Color4 GLfloat
1 GLfloat
1 GLfloat
1 GLfloat
1

  Face -> StateVar (Color4 GLfloat)
GLUT.materialDiffuse Face
Front forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> a -> a -> a -> Color4 a
Color4 GLfloat
0.5 GLfloat
0.5 GLfloat
0.5 GLfloat
1
  Face -> StateVar (Color4 GLfloat)
GLUT.materialSpecular Face
Front forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> a -> a -> a -> Color4 a
Color4 GLfloat
1 GLfloat
1 GLfloat
1 GLfloat
1
  Face -> StateVar GLfloat
GLUT.materialShininess Face
Front forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLfloat
100
  StateVar (Maybe (Face, ColorMaterialParameter))
GLUT.colorMaterial forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just (Face
Front, ColorMaterialParameter
Diffuse)

  case Options -> Antialiasing
optAntialiasing Options
opts of
    Antialiasing
Aliased -> do
      StateVar Capability
GLUT.lineSmooth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled
      StateVar Capability
GLUT.pointSmooth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled
      StateVar Capability
GLUT.multisample forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled
    Antialiasing
Smoothed -> do
      HintTarget -> StateVar HintMode
GLUT.hint HintTarget
GLUT.LineSmooth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= HintMode
GLUT.Nicest
      HintTarget -> StateVar HintMode
GLUT.hint HintTarget
GLUT.PointSmooth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= HintMode
GLUT.Nicest
      StateVar Capability
GLUT.lineSmooth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
      StateVar Capability
GLUT.pointSmooth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
      StateVar Capability
GLUT.multisample forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled
    Multisampled Int
_ -> do
      StateVar Capability
GLUT.lineSmooth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled
      StateVar Capability
GLUT.pointSmooth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Disabled
      StateVar Capability
GLUT.multisample forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled

  forall (m :: * -> *). MonadIO m => GLenum -> m ()
glEnable GLenum
GL_BLEND
  forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m ()
glBlendFunc GLenum
GL_SRC_ALPHA GLenum
GL_ONE_MINUS_SRC_ALPHA

drawScene :: MVar (FullState a) -> MVar Bool -> IO () -> (FullState a -> IO ()) -> DisplayCallback
drawScene :: forall a.
MVar (FullState a)
-> MVar Bool -> IO () -> (FullState a -> IO ()) -> IO ()
drawScene MVar (FullState a)
stateMVar MVar Bool
visReadyMVar IO ()
setCameraFun FullState a -> IO ()
userDrawFun = do
   [ClearBuffer] -> IO ()
GLUT.clear [ ClearBuffer
ColorBuffer, ClearBuffer
DepthBuffer ]

   -- draw the scene
   forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
     -- set the camera's position and orientation
     IO ()
setCameraFun

     -- call user function
     FullState a
state <- forall a. MVar a -> IO a
readMVar MVar (FullState a)
stateMVar
     FullState a -> IO ()
userDrawFun FullState a
state

   IO ()
GLUT.flush
   forall (m :: * -> *). MonadIO m => m ()
GLUT.swapBuffers
   Bool
_ <- forall a. MVar a -> a -> IO a
swapMVar MVar Bool
visReadyMVar Bool
True
   forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay forall a. Maybe a
Nothing


reshape :: ReshapeCallback
reshape :: ReshapeCallback
reshape size :: Size
size@(Size GLint
_ GLint
_) = do
   StateVar (Position, Size)
GLUT.viewport forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (GLint -> GLint -> Position
Position GLint
0 GLint
0, Size
size)
   IO ()
setPerspectiveMode
   IO ()
GLUT.loadIdentity
   forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay forall a. Maybe a
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 :: forall b a.
Real b =>
Options
-> Double
-> a
-> (FullState a -> IO a)
-> (FullState a -> IO (VisObject b, Maybe Cursor))
-> (a -> IO ())
-> Maybe (a -> Key -> KeyState -> Modifiers -> Position -> a)
-> Maybe (a -> Position -> a)
-> Maybe (a -> Position -> a)
-> IO ()
vis Options
opts Double
ts a
x0 FullState a -> IO a
userSimFun FullState a -> IO (VisObject b, Maybe Cursor)
userDraw a -> IO ()
userSetCamera
  Maybe (a -> Key -> KeyState -> Modifiers -> Position -> a)
userKeyMouseCallback Maybe (a -> Position -> a)
userMotionCallback Maybe (a -> Position -> a)
userPassiveMotionCallback = do
  -- init glut/scene
  (String, [String])
_ <- forall (m :: * -> *). MonadIO m => m (String, [String])
GLUT.getArgsAndInitialize

  Options -> IO ()
myGlInit Options
opts

  -- create internal state
  let fullState0 :: FullState a
fullState0 = (a
x0, GLfloat
0)
  MVar (FullState a)
stateMVar <- forall a. a -> IO (MVar a)
newMVar FullState a
fullState0
  MVar Bool
visReadyMVar <- forall a. a -> IO (MVar a)
newMVar Bool
False

  -- start sim thread
  ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a.
MVar (FullState a)
-> MVar Bool -> (FullState a -> IO a) -> Double -> IO ()
simThread MVar (FullState a)
stateMVar MVar Bool
visReadyMVar FullState a -> IO a
userSimFun Double
ts

  -- setup the callbacks
  let makePictures :: FullState a -> IO ()
makePictures FullState a
x = do
        (VisObject b
visobs,Maybe Cursor
cursor') <- FullState a -> IO (VisObject b, Maybe Cursor)
userDraw FullState a
x
        VisObject Double -> IO ()
drawObjects forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Real a, Fractional b) => a -> b
realToFrac) VisObject b
visobs
        case Maybe Cursor
cursor' of Maybe Cursor
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Just Cursor
cursor'' -> StateVar Cursor
GLUT.cursor forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Cursor
cursor''

      setCamera' :: IO ()
setCamera' = do
        (a
state,GLfloat
_) <- forall a. MVar a -> IO a
readMVar MVar (FullState a)
stateMVar
        a -> IO ()
userSetCamera a
state

      -- kill sim thread when someone hits ESC
      exitOverride :: KeyboardMouseCallback
exitOverride Key
k0 KeyState
k1 Modifiers
k2 Position
k3 = case (Key
k0,KeyState
k1) of
        (Char Char
'\27', KeyState
Down) -> forall a. IO a
exitSuccess
        (Key, KeyState)
_ -> case Maybe (a -> Key -> KeyState -> Modifiers -> Position -> a)
userKeyMouseCallback of
          Maybe (a -> Key -> KeyState -> Modifiers -> Position -> a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just a -> Key -> KeyState -> Modifiers -> Position -> a
cb -> do
            (a
state0',GLfloat
time) <- forall a. MVar a -> IO a
takeMVar MVar (FullState a)
stateMVar
            forall a. MVar a -> a -> IO ()
putMVar MVar (FullState a)
stateMVar (a -> Key -> KeyState -> Modifiers -> Position -> a
cb a
state0' Key
k0 KeyState
k1 Modifiers
k2 Position
k3, GLfloat
time)
            forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay forall a. Maybe a
Nothing

      motionCallback' :: MotionCallback
motionCallback' Position
pos = case Maybe (a -> Position -> a)
userMotionCallback of
        Maybe (a -> Position -> a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just a -> Position -> a
cb -> do
          (a
state0',GLfloat
ts') <- forall a. MVar a -> IO a
takeMVar MVar (FullState a)
stateMVar
          forall a. MVar a -> a -> IO ()
putMVar MVar (FullState a)
stateMVar (a -> Position -> a
cb a
state0' Position
pos, GLfloat
ts')
          forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay forall a. Maybe a
Nothing

      passiveMotionCallback' :: MotionCallback
passiveMotionCallback' Position
pos = case Maybe (a -> Position -> a)
userPassiveMotionCallback of
        Maybe (a -> Position -> a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just a -> Position -> a
cb -> do
          (a
state0',GLfloat
ts') <- forall a. MVar a -> IO a
takeMVar MVar (FullState a)
stateMVar
          forall a. MVar a -> a -> IO ()
putMVar MVar (FullState a)
stateMVar (a -> Position -> a
cb a
state0' Position
pos, GLfloat
ts')
          forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay forall a. Maybe a
Nothing

  SettableStateVar (IO ())
GLUT.displayCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a.
MVar (FullState a)
-> MVar Bool -> IO () -> (FullState a -> IO ()) -> IO ()
drawScene MVar (FullState a)
stateMVar MVar Bool
visReadyMVar IO ()
setCamera' FullState a -> IO ()
makePictures
  SettableStateVar (Maybe ReshapeCallback)
GLUT.reshapeCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just ReshapeCallback
reshape
  SettableStateVar (Maybe KeyboardMouseCallback)
GLUT.keyboardMouseCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just KeyboardMouseCallback
exitOverride
  SettableStateVar (Maybe MotionCallback)
GLUT.motionCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just MotionCallback
motionCallback'
  SettableStateVar (Maybe MotionCallback)
GLUT.passiveMotionCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just MotionCallback
passiveMotionCallback'

  -- start main loop
  forall (m :: * -> *). MonadIO m => m ()
GLUT.mainLoop

simThread :: MVar (FullState a) -> MVar Bool -> (FullState a -> IO a) -> Double -> IO ()
simThread :: forall a.
MVar (FullState a)
-> MVar Bool -> (FullState a -> IO a) -> Double -> IO ()
simThread MVar (FullState a)
stateMVar MVar Bool
visReadyMVar FullState a -> IO a
userSimFun Double
ts = do
  let waitUntilDisplayIsReady :: IO ()
      waitUntilDisplayIsReady :: IO ()
waitUntilDisplayIsReady = do -- todo: why not just block?
        Bool
visReady <- forall a. MVar a -> IO a
readMVar MVar Bool
visReadyMVar
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
visReady forall a b. (a -> b) -> a -> b
$ do
          Int -> IO ()
threadDelay Int
10000
          IO ()
waitUntilDisplayIsReady

  IO ()
waitUntilDisplayIsReady

  UTCTime
t0 <- IO UTCTime
getCurrentTime
  IORef UTCTime
lastTimeRef <- forall a. a -> IO (IORef a)
newIORef UTCTime
t0

  forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    -- calculate how much longer to sleep before taking a timestep
    UTCTime
currentTime <- IO UTCTime
getCurrentTime
    UTCTime
lastTime <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
GLUT.get IORef UTCTime
lastTimeRef
    let usRemaining :: Int
        usRemaining :: Int
usRemaining = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
1e6forall a. Num a => a -> a -> a
*(Double
ts forall a. Num a => a -> a -> a
- forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
currentTime UTCTime
lastTime))
        secondsSinceStart :: GLfloat
secondsSinceStart = forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
currentTime UTCTime
t0)

    if Int
usRemaining forall a. Ord a => a -> a -> Bool
<= Int
0
      -- slept for long enough, do a sim iteration
      then do
        IORef UTCTime
lastTimeRef forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
ts) UTCTime
lastTime

        let getNextState :: IO a
getNextState = do
              FullState a
state <- forall a. MVar a -> IO a
readMVar MVar (FullState a)
stateMVar
              FullState a -> IO a
userSimFun FullState a
state
            putState :: a -> IO (FullState a)
putState a
x = forall a. MVar a -> a -> IO a
swapMVar MVar (FullState a)
stateMVar (a
x, GLfloat
secondsSinceStart)

        a
nextState <- IO a
getNextState
        FullState a
_ <- a
nextState seq :: forall a b. a -> b -> b
`seq` a -> IO (FullState a)
putState a
nextState

        forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay forall a. Maybe a
Nothing

      -- need to sleep longer
      else Int -> IO ()
threadDelay Int
usRemaining




movieSimThread :: [VisObject a] -> MVar ([VisObject a], Camera) -> MVar Bool -> Double -> IO ()
movieSimThread :: forall a.
[VisObject a]
-> MVar ([VisObject a], Camera) -> MVar Bool -> Double -> IO ()
movieSimThread [VisObject a]
objects0 MVar ([VisObject a], Camera)
stateMVar MVar Bool
visReadyMVar Double
ts = do
  let waitUntilDisplayIsReady :: IO ()
      waitUntilDisplayIsReady :: IO ()
waitUntilDisplayIsReady = do -- todo: why not just block?
        Bool
visReady <- forall a. MVar a -> IO a
readMVar MVar Bool
visReadyMVar
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
visReady forall a b. (a -> b) -> a -> b
$ do
          Int -> IO ()
threadDelay Int
10000
          IO ()
waitUntilDisplayIsReady

  IO ()
waitUntilDisplayIsReady

  UTCTime
t0 <- IO UTCTime
getCurrentTime
  IORef UTCTime
lastTimeRef <- forall a. a -> IO (IORef a)
newIORef UTCTime
t0

  forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    -- calculate how much longer to sleep before taking a timestep
    UTCTime
currentTime <- IO UTCTime
getCurrentTime
    UTCTime
lastTime <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
GLUT.get IORef UTCTime
lastTimeRef
    let usRemaining :: Int
        usRemaining :: Int
usRemaining = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
1e6forall a. Num a => a -> a -> a
*(Double
ts forall a. Num a => a -> a -> a
- forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
currentTime UTCTime
lastTime))

    if Int
usRemaining forall a. Ord a => a -> a -> Bool
<= Int
0
      -- slept for long enough, do a sim iteration
      then do
        IORef UTCTime
lastTimeRef forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
ts) UTCTime
lastTime

        let getNextState :: IO ([VisObject a], Camera)
getNextState = do
              ([VisObject a], Camera)
state <- forall a. MVar a -> IO a
readMVar MVar ([VisObject a], Camera)
stateMVar
              let next :: ([VisObject a], Camera)
next = case ([VisObject a], Camera)
state of
                    (VisObject a
_:[VisObject a]
xs, Camera
cs) -> ([VisObject a]
xs, Camera
cs)
                    ([], Camera
cs) -> ([VisObject a]
objects0, Camera
cs)
              forall (m :: * -> *) a. Monad m => a -> m a
return ([VisObject a], Camera)
next
            putState :: ([VisObject a], Camera) -> IO ([VisObject a], Camera)
putState ([VisObject a], Camera)
x = forall a. MVar a -> a -> IO a
swapMVar MVar ([VisObject a], Camera)
stateMVar ([VisObject a], Camera)
x

        ([VisObject a], Camera)
nextState <- IO ([VisObject a], Camera)
getNextState
        ([VisObject a], Camera)
_ <- ([VisObject a], Camera)
nextState seq :: forall a b. a -> b -> b
`seq` ([VisObject a], Camera) -> IO ([VisObject a], Camera)
putState ([VisObject a], Camera)
nextState

        forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay forall a. Maybe a
Nothing

      -- need to sleep longer
      else Int -> IO ()
threadDelay Int
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 :: forall b.
Real b =>
Options
-> (Int -> String)
-> Double
-> [VisObject b]
-> Maybe Cursor
-> IO ()
visMovie = forall b.
Real b =>
Bool
-> Options
-> (Int -> String)
-> Double
-> [VisObject b]
-> Maybe Cursor
-> IO ()
visMovie' Bool
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 :: forall b.
Real b =>
Options
-> (Int -> String)
-> Double
-> [VisObject b]
-> Maybe Cursor
-> IO ()
visMovieImmediately = forall b.
Real b =>
Bool
-> Options
-> (Int -> String)
-> Double
-> [VisObject b]
-> Maybe Cursor
-> IO ()
visMovie' Bool
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' :: forall b.
Real b =>
Bool
-> Options
-> (Int -> String)
-> Double
-> [VisObject b]
-> Maybe Cursor
-> IO ()
visMovie' Bool
startImmediately Options
opts Int -> String
toFilename Double
ts [VisObject b]
objectsToDraw Maybe Cursor
maybeCursor = do
  -- init glut/scene
  (String, [String])
_ <- forall (m :: * -> *). MonadIO m => m (String, [String])
GLUT.getArgsAndInitialize

  Options -> IO ()
myGlInit Options
opts

  let defaultCam :: Camera0
defaultCam =
        Camera0 { phi0 :: Double
phi0 = Double
60
                , theta0 :: Double
theta0 = Double
20
                , rho0 :: Double
rho0 = Double
7}
      cameraState0 :: Camera
cameraState0 = Camera0 -> Camera
makeCamera forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Camera0
defaultCam (Options -> Maybe Camera0
optInitialCamera Options
opts)

  -- create internal state
  IORef Bool
areWeDrawingRef <- forall a. a -> IO (IORef a)
newIORef Bool
False
  MVar ([VisObject b], Camera)
stateMVar <- forall a. a -> IO (MVar a)
newMVar ([VisObject b]
objectsToDraw, Camera
cameraState0)
  MVar Bool
visReadyMVar <- forall a. a -> IO (MVar a)
newMVar Bool
startImmediately

  -- start sim thread
  ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a.
[VisObject a]
-> MVar ([VisObject a], Camera) -> MVar Bool -> Double -> IO ()
movieSimThread [VisObject b]
objectsToDraw MVar ([VisObject b], Camera)
stateMVar MVar Bool
visReadyMVar Double
ts

  -- setup the callbacks
  let makePictures :: VisObject b -> Camera -> IO ()
      makePictures :: VisObject b -> Camera -> IO ()
makePictures VisObject b
visobj Camera
cam = do
        [ClearBuffer] -> IO ()
GLUT.clear [ ClearBuffer
ColorBuffer, ClearBuffer
DepthBuffer ]

        -- draw the scene
        forall a. IO a -> IO a
GLUT.preservingMatrix forall a b. (a -> b) -> a -> b
$ do
          Camera -> IO ()
setCamera Camera
cam
          VisObject Double -> IO ()
drawObjects forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Real a, Fractional b) => a -> b
realToFrac) VisObject b
visobj
          case Maybe Cursor
maybeCursor of
           Maybe Cursor
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           Just Cursor
cursor -> StateVar Cursor
GLUT.cursor forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Cursor
cursor

        IO ()
GLUT.flush
        forall (m :: * -> *). MonadIO m => m ()
GLUT.swapBuffers
        Bool
_ <- forall a. MVar a -> a -> IO a
swapMVar MVar Bool
visReadyMVar Bool
True
        forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay forall a. Maybe a
Nothing

      screenShot :: Int -> Camera -> (VisObject b, Int) -> IO ()
      screenShot :: Int -> Camera -> (VisObject b, Int) -> IO ()
screenShot Int
n Camera
camera (VisObject b
visobj, Int
imageNumber) = do
        -- todo: are width/height reversed?
        size :: Size
size@(Size GLint
width GLint
height) <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
GLUT.get StateVar Size
GLUT.windowSize
        let pos :: Position
pos = GLint -> GLint -> Position
Position GLint
0 GLint
0
        Ptr GLubyte
ubytePtr <- forall a. Storable a => Int -> IO (Ptr a)
mallocArray (forall a b. (Integral a, Num b) => a -> b
fromIntegral (GLint
4forall a. Num a => a -> a -> a
*GLint
widthforall a. Num a => a -> a -> a
*GLint
height)) :: IO (Ptr GLubyte)
        let pixelData :: PixelData GLubyte
pixelData = forall a. PixelFormat -> DataType -> Ptr a -> PixelData a
GLUT.PixelData PixelFormat
GLUT.RGBA DataType
GLUT.UnsignedByte Ptr GLubyte
ubytePtr
        VisObject b -> Camera -> IO ()
makePictures VisObject b
visobj Camera
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
        IO ()
GLUT.finish
        forall a. Position -> Size -> PixelData a -> IO ()
GLUT.readPixels Position
pos Size
size PixelData GLubyte
pixelData
        let wordPtr :: Ptr Word8
            wordPtr :: Ptr GLubyte
wordPtr
              | forall a. Storable a => a -> Int
sizeOf (GLubyte
0 :: GLubyte) forall a. Eq a => a -> a -> Bool
== forall a. Storable a => a -> Int
sizeOf (GLubyte
0 :: Word8) = forall a b. Ptr a -> Ptr b
castPtr Ptr GLubyte
ubytePtr
              | Bool
otherwise = forall a. HasCallStack => String -> a
error String
"GLubyte size /= Word8 size"

        ByteString
bs <- Ptr GLubyte -> Int -> IO () -> IO ByteString
BS.unsafePackCStringFinalizer
              Ptr GLubyte
wordPtr (forall a b. (Integral a, Num b) => a -> b
fromIntegral (GLint
4forall a. Num a => a -> a -> a
*GLint
widthforall a. Num a => a -> a -> a
*GLint
height)) (forall a. Ptr a -> IO ()
free Ptr GLubyte
ubytePtr)
        let bmp :: BMP
            bmp :: BMP
bmp = Int -> Int -> ByteString -> BMP
packRGBA32ToBMP32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
width) (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
height) ByteString
bs

        let filename :: String
filename = Int -> String
toFilename Int
imageNumber
            percent :: Double
            percent :: Double
percent = Double
100 forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
imageNumber forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
        forall r. PrintfType r => String -> r
printf String
"writing \"%s\" (%d / %d == %6.2f %%) ...\n" String
filename Int
imageNumber Int
n Double
percent
        String -> BMP -> IO ()
writeBMP String
filename BMP
bmp

      drawFun :: IO ()
drawFun = do
        Bool
areWeDrawing <- forall a. IORef a -> IO a
readIORef IORef Bool
areWeDrawingRef
        ([VisObject b]
state,Camera
cam) <- forall a. MVar a -> IO a
readMVar MVar ([VisObject b], Camera)
stateMVar
        if Bool
areWeDrawing
          then do let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [VisObject b]
objectsToDraw
                  ([VisObject b], Camera)
state' <- forall a. MVar a -> IO a
takeMVar MVar ([VisObject b], Camera)
stateMVar
                  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int -> Camera -> (VisObject b, Int) -> IO ()
screenShot Int
n Camera
cam) (forall a b. [a] -> [b] -> [(a, b)]
zip [VisObject b]
objectsToDraw [Int
0..])
                  String -> IO ()
putStrLn String
"finished writing files"
                  String -> IO ()
putStrLn String
"you might want to try some command like:"
                  String -> IO ()
putStrLn String
"\"ffmpeg -framerate 50 -i data/movie.%03d.bmp -c:v libx264 -r 30 -pix_fmt yuv420p out.mp4\""
                  forall a. MVar a -> a -> IO ()
putMVar MVar ([VisObject b], Camera)
stateMVar ([VisObject b], Camera)
state'

                  forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
areWeDrawingRef Bool
False
          else do let visobj :: VisObject b
visobj = case ([VisObject b]
state, [VisObject b]
objectsToDraw) of
                        (VisObject b
y:[VisObject b]
_, [VisObject b]
_) -> VisObject b
y -- draw head object
                        ([], VisObject b
y:[VisObject b]
_) -> VisObject b
y -- empty state so just draw first object
                        ([], []) -> forall a. [VisObject a] -> VisObject a
VisObjects [] -- nothing available
                  VisObject b -> Camera -> IO ()
makePictures VisObject b
visobj Camera
cam

      exitOverride :: Key -> KeyState -> p -> p -> IO ()
exitOverride Key
k0 KeyState
k1 p
_k2 p
_k3 = case (Key
k0,KeyState
k1) of
        -- ESC button exits the program
        (Char Char
'\27', KeyState
Down) -> forall a. IO a
exitSuccess
        -- space bar starts screenshots
        (Char Char
' ', KeyState
Down) -> forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
areWeDrawingRef Bool
True
        (Key, KeyState)
_ -> do
          ([VisObject b]
state0', Camera
cs) <- forall a. MVar a -> IO a
takeMVar MVar ([VisObject b], Camera)
stateMVar
          forall a. MVar a -> a -> IO ()
putMVar MVar ([VisObject b], Camera)
stateMVar ([VisObject b]
state0', Camera -> Key -> KeyState -> Camera
cameraKeyboardMouse Camera
cs Key
k0 KeyState
k1)
          forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay forall a. Maybe a
Nothing

      motionCallback' :: MotionCallback
motionCallback' Position
pos = do
        ([VisObject b]
state0', Camera
cs) <- forall a. MVar a -> IO a
takeMVar MVar ([VisObject b], Camera)
stateMVar
        forall a. MVar a -> a -> IO ()
putMVar MVar ([VisObject b], Camera)
stateMVar ([VisObject b]
state0', Camera -> Position -> Camera
cameraMotion Camera
cs Position
pos)
        forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay forall a. Maybe a
Nothing

--      passiveMotionCallback' pos = case userPassiveMotionCallback of
--        Nothing -> return ()
--        Just cb -> do
--          (state0', cs) <- takeMVar stateMVar
--          putMVar stateMVar (cb state0' pos, cs)
--          GLUT.postRedisplay Nothing

  SettableStateVar (IO ())
GLUT.displayCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= IO ()
drawFun
  SettableStateVar (Maybe ReshapeCallback)
GLUT.reshapeCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just ReshapeCallback
reshape
  SettableStateVar (Maybe KeyboardMouseCallback)
GLUT.keyboardMouseCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just forall {p} {p}. Key -> KeyState -> p -> p -> IO ()
exitOverride
  SettableStateVar (Maybe MotionCallback)
GLUT.motionCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just MotionCallback
motionCallback'
--  GLUT.passiveMotionCallback $= Just passiveMotionCallback'

  -- start main loop
  forall (m :: * -> *). MonadIO m => m ()
GLUT.mainLoop