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