bullet-0.1.1: Examples/BulletExample.hs
import Control.Monad
import Control.Concurrent.MVar
import System.Exit
import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL
import Graphics.Rendering.OpenGL.GL.CoordTrans
import Unsafe.Coerce -- because realToFrac just doesn't cut it...
import Physics.Bullet
import Foreign hiding (rotate)
timerFrequencyMillis :: Timeout
timerFrequencyMillis = 1
data BCube = BCube (GLfloat,GLfloat,GLfloat,PlRigidBodyHandle,(GLfloat,GLfloat,GLfloat,GLfloat))
data State = State {
dworld :: PlDynamicsWorldHandle,
cubes :: [BCube],
viewAngle :: MVar GLfloat,
viewHeight :: MVar GLfloat,
paused :: MVar Bool
}
createBCube dw ((x,y,z), (w,h,d), m, col) = do
shape <- plNewBoxShape w h d
b <- plCreateRigidBody Foreign.nullPtr m shape
plAddRigidBody dw b
plSetPosition b (x,y,z)
return $ BCube (unsafeCoerce w,unsafeCoerce h,unsafeCoerce d,b,col)
lightPosition = Vertex4 5 20 10 0
lightPositionDeltas = map calcDelta [0..lightSteps-1]
where Vertex4 lxo lyo lzo _ = lightPosition
calcDelta l = (lightSize*(lx1*sin ll+lx2*cos ll),
lightSize*(ly1*sin ll+ly2*cos ll),
lightSize*(lz1*sin ll+lz2*cos ll))
where ll = 2*pi*l/lightSteps
ll1 = sqrt (lxo*lxo+lzo*lzo)
(lx1,ly1,lz1) = (lzo/ll1,0,-lxo/ll1)
ll2 = sqrt (lxo*lxo*lyo*lyo+(lxo*lxo+lzo*lzo)*(lxo*lxo+lzo*lzo)+lzo*lzo*lyo*lyo)
(lx2,ly2,lz2) = (-lxo*lyo/ll2,(lxo*lxo+lzo*lzo)/ll2,-lzo*lyo/ll2)
lightSteps = 8
lightSize = 0.3
camDistance = 8
makeState :: IO State
makeState = do
sdk <- plNewBulletSdk
dw <- plCreateDynamicsWorld sdk
ang <- newMVar 0
h <- newMVar (-6)
p <- newMVar False
-- set up bullet scene
cs <- mapM (createBCube dw) $ [
((0,-0.1,0), (50.0,0.1,50.0), 0, (0.9,0.9,0.9,1)),
((4,15,-0.5), (1,1,1), 10, blue)
]
++ map (\x -> ((-5+x*0.5,0.5+10-abs(x-10),0), (0.5,0.5,0.5), 1, green)) [0..20]
++ map (\x -> let h = min 4.5 (5-abs(x-5)) in ((-5+x,h,0), (0.1,h,0.1), 2, yellow)) [1..9]
return $ State {
dworld = dw,
cubes = cs,
viewAngle = ang,
viewHeight = h,
paused = p
}
where green = (0,1,0,1)
yellow = (1,1,0,1)
blue = (0,0,1,1)
display :: State -> DisplayCallback
display state = do
loadIdentity
height <- readMVar $ viewHeight state
rotate (-atan ((height+3)/camDistance)*180/pi) (Vector3 1 0 (0 :: GLfloat))
translate (Vector3 0 height (-camDistance))
angle <- readMVar $ viewAngle state
rotate angle (Vector3 0 1 0)
scale (1 :: GLfloat) 1 1
position (Light 0) $= lightPosition
let cs = cubes state
-- draw fully lit scene
clear [ColorBuffer, DepthBuffer]
cullFace $= Just Back
forM_ cs $ \(BCube (w,h,d,body,(r,g,b,a))) -> do
materialDiffuse Front $= Color4 r g b a
preservingMatrix $ do
-- get position and orientation of body
(e0,e1,e2,e3,e4,e5,e6,e7,e8,e9,eA,eB,eC,eD,eE,eF) <- plGetOpenGLMatrix body
let f = unsafeCoerce
m <- newMatrix ColumnMajor $ [f e0,f e1,f e2,f e3,f e4,f e5,f e6,f e7,f e8,f e9,f eA,f eB,f eC,f eD,f eE,f eF]
-- set position and orientation of gl modelview matrix
multMatrix (m :: GLmatrix GLfloat)
drawCube w h d
-- settings needed for casting
depthMask $= Disabled
stencilTest $= Enabled
forM_ lightPositionDeltas $ \lpd -> do
-- generate shadow volumes (note that they are open-ended!)
svs <- forM (tail cs) $ \(BCube (w,h,d,body,_)) -> do
(px,py,pz) <- plGetPosition body
(ox,oy,oz,ow) <- plGetOrientation body
return $ (body, cubeShadow lpd (-unsafeCoerce px,-unsafeCoerce py,-unsafeCoerce pz) (unsafeCoerce ow,-unsafeCoerce ox,-unsafeCoerce oy,-unsafeCoerce oz) w h d)
renderShadows svs
-- restore settings
stencilTest $= Disabled
depthMask $= Enabled
flush
swapBuffers
renderShadows svs = do
-- increment stencil for the front faces of shadow volumes
lighting $= Disabled
colorMask $= Color4 Disabled Disabled Disabled Disabled
stencilFunc $= (Always, 0, 0)
stencilOp $= (OpKeep, OpKeep, OpIncrWrap)
drawShadowVolumes svs
-- decrement stencil for the back faces of shadow volumes
cullFace $= Just Front
stencilOp $= (OpKeep, OpKeep, OpDecrWrap)
drawShadowVolumes svs
-- apply shadow using the stencil buffer
colorMask $= Color4 Enabled Enabled Enabled Enabled
depthFunc $= Just Less
stencilOp $= (OpZero, OpZero, OpZero)
stencilFunc $= (Less, 0, 0xffffffff)
lighting $= Enabled
cullFace $= Just Back
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
materialDiffuse Front $= Color4 0 0 0 (0.4/lightSteps)
preservingMatrix $ do
loadIdentity
renderPrimitive TriangleStrip $ do
vertex $ Vertex3 (-10) 10 (-1 :: GLfloat)
vertex $ Vertex3 (-10) (-10) (-1 :: GLfloat)
vertex $ Vertex3 10 10 (-1 :: GLfloat)
vertex $ Vertex3 10 (-10) (-1 :: GLfloat)
blend $= Disabled
drawShadowVolumes svs =
forM_ svs $ \(body,vs) -> do
preservingMatrix $ do
-- get position and orientation of body
(e0,e1,e2,e3,e4,e5,e6,e7,e8,e9,eA,eB,eC,eD,eE,eF) <- plGetOpenGLMatrix body
let f = unsafeCoerce
m <- newMatrix ColumnMajor $ [f e0,f e1,f e2,f e3,f e4,f e5,f e6,f e7,f e8,f e9,f eA,f eB,f eC,f eD,f eE,f eF]
-- set position and orientation of gl modelview matrix
multMatrix (m :: GLmatrix GLfloat)
renderPrimitive Quads $ forM_ vs $ \(p1,p2,p3,p4) -> do
vertex p1
vertex p2
vertex p3
vertex p4
keyboard :: State -> KeyboardMouseCallback
keyboard state key keyState mods _ = do
case (key, keyState) of
(Char 'q', Down) -> exitWith ExitSuccess
(Char '\27', Down) -> exitWith ExitSuccess
--(Char 't', Down) -> modelCycle state $~ tail
--(SpecialKey KeyHome, Down) -> resetState state
(SpecialKey KeyLeft, Down) -> do
angle <- takeMVar $ viewAngle state
putMVar (viewAngle state) (angle+2)
(SpecialKey KeyRight, Down) -> do
angle <- takeMVar $ viewAngle state
putMVar (viewAngle state) (angle-2)
(SpecialKey KeyUp, Down) -> do
height <- takeMVar $ viewHeight state
putMVar (viewHeight state) (height-0.2)
(SpecialKey KeyDown, Down) -> do
height <- takeMVar $ viewHeight state
putMVar (viewHeight state) (height+0.2)
(Char 'p', Down) -> do
isPaused <- takeMVar $ paused state
putMVar (paused state) (not isPaused)
(_, _) -> return ()
reshape :: ReshapeCallback
reshape size@(Size w h) = do
let vp = 0.8
aspect = fromIntegral w / fromIntegral h
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
frustum (-vp) vp (-vp / aspect) (vp / aspect) 1 1000
matrixMode $= Modelview 0
loadIdentity
translate (Vector3 0 0 (-5 :: GLfloat))
timer :: State -> TimerCallback
timer state = do
addTimerCallback timerFrequencyMillis (timer state)
isPaused <- readMVar $ paused state
when (not isPaused) $ plStepSimulation (dworld state) (fromIntegral(timerFrequencyMillis))
postRedisplay Nothing
drawFace :: Normal3 GLfloat -> Vertex3 GLfloat -> Vertex3 GLfloat
-> Vertex3 GLfloat -> Vertex3 GLfloat -> IO ()
drawFace p q r s t = do
let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO ()
normal p
texCoord2f (TexCoord2 1 1)
vertex q
texCoord2f (TexCoord2 0 1)
vertex r
texCoord2f (TexCoord2 0 0)
vertex s
texCoord2f (TexCoord2 1 0)
vertex t
drawCube :: GLfloat -> GLfloat -> GLfloat -> IO ()
drawCube sx sy sz = do
let a = Vertex3 sx sy sz
b = Vertex3 sx sy (-sz)
c = Vertex3 sx (-sy) (-sz)
d = Vertex3 sx (-sy) sz
e = Vertex3 (-sx) sy sz
f = Vertex3 (-sx) sy (-sz)
g = Vertex3 (-sx) (-sy) (-sz)
h = Vertex3 (-sx) (-sy) sz
i = Normal3 1 0 0
k = Normal3 (-1) 0 0
l = Normal3 0 0 (-1)
m = Normal3 0 0 1
n = Normal3 0 1 0
o = Normal3 0 (-1) 0
renderPrimitive Quads $ do
drawFace i d c b a
drawFace k g h e f
drawFace l c g f b
drawFace m h d a e
drawFace n e a b f
drawFace o g c d h
cubeShadow (ldx,ldy,ldz) (x,y,z) (a,b,c,d) sx sy sz =
map shadowFace $ filter shouldCast edges
where [oxx,oxy,oxz,oyx,oyy,oyz,ozx,ozy,ozz] =
[a*a+b*b-c*c-d*d, 2*(b*c-a*d), 2*(a*c+b*d),
2*(a*d+b*c), a*a-b*b+c*c-d*d, 2*(c*d-a*b),
2*(b*d-a*c), 2*(a*b+c*d), a*a-b*b-c*c+d*d]
Vertex4 lxo lyo lzo _ = lightPosition
(lxt,lyt,lzt) = (lxo+ldx+x,lyo+ldy+y,lzo+ldz+z)
(lx,ly,lz) = (lxt*oxx+lyt*oxy+lzt*oxz,
lxt*oyx+lyt*oyy+lzt*oyz,
lxt*ozx+lyt*ozy+lzt*ozz)
ni = lx > sx
nk = lx < (-sx)
nl = lz < (-sz)
nm = lz > sz
nn = ly > sy
no = ly < (-sy)
va = ( sx, sy, sz)
vb = ( sx, sy,-sz)
vc = ( sx,-sy,-sz)
vd = ( sx,-sy, sz)
ve = (-sx, sy, sz)
vf = (-sx, sy,-sz)
vg = (-sx,-sy,-sz)
vh = (-sx,-sy, sz)
edges = [(vd,vc,ni,no),(vc,vb,ni,nl),(vb,va,ni,nn),(va,vd,ni,nm),
(vg,vh,nk,no),(vf,vg,nk,nl),(ve,vf,nk,nn),(vh,ve,nk,nm),
(vc,vg,nl,no),(vf,vb,nl,nn),(vh,vd,nm,no),(va,ve,nm,nn)]
shouldCast (_,_,c1,c2) = (c1 && (not c2)) || (c2 && (not c1))
shadowFace ((v1x,v1y,v1z),(v2x,v2y,v2z),n1,n2) =
if n2 then
(Vertex3 v1x v1y v1z, Vertex3 v2x v2y v2z,
Vertex3 v3x v3y v3z, Vertex3 v4x v4y v4z)
else
(Vertex3 v4x v4y v4z, Vertex3 v3x v3y v3z,
Vertex3 v2x v2y v2z, Vertex3 v1x v1y v1z)
where ss = 1000
v3x = v2x+(v2x-lx)*ss
v3y = v2y+(v2y-ly)*ss
v3z = v2z+(v2z-lz)*ss
v4x = v1x+(v1x-lx)*ss
v4y = v1y+(v1y-ly)*ss
v4z = v1z+(v1z-lz)*ss
main = do
getArgsAndInitialize
initialDisplayMode $= [RGBMode, WithDepthBuffer, WithStencilBuffer, DoubleBuffered, Multisampling]
initialWindowSize $= Size 800 800
createWindow "Bullet Example"
state <- makeState
displayCallback $= display state
keyboardMouseCallback $= Just (keyboard state)
reshapeCallback $= Just reshape
addTimerCallback timerFrequencyMillis (timer state)
materialDiffuse Front $= Color4 1 0.3 0.2 1
materialSpecular Front $= Color4 0.3 0.3 0.3 1
materialShininess Front $= 16
lighting $= Enabled
light (Light 0) $= Enabled
depthFunc $= Just Less
clearColor $= Color4 0.0 0.0 0.0 1
clear [StencilBuffer]
mainLoop