content: module Dirty where
  
  import System.IO
  import Data.Word
  
  import Control.Applicative
  
  import Data.List
  import Control.Monad.IO.Class
  import Data.IORef
  import Data.StateVar
  
  import qualified Physics.Hipmunk as H
  import qualified Graphics.UI.GLFW as G
  import qualified Graphics.Rendering.OpenGL as G
  import Types
  import Utils
  import Inits
  
  import qualified IxMap as M
  
  import qualified Control.Monad.Random as R
  import System.Random
  
  stepDirty :: H.Time -> Dirty -> IO Dirty
  stepDirty dt d = H.step (dirtySpace d) dt >> return d
  
  
  obj2hero    :: Obj -> IO HeroBall
  obj2ball    :: Id -> Obj -> IO Ball
  
  obj2hero a  = do
      p <- get $ objPos a
      v <- get $ objVel a
      return $ HeroBall 
          { heroPos   = p
          , heroVel   = H.len v }
  
  obj2ball i a = do
      p <- get $ objPos a
      return $ Ball 
          { ballId    = i
          , ballPos   = p
          , ballType  = objType a } 
  
  
  objPos = H.position . objBody
  objVel = H.velocity . objBody
  
  getTouch    :: Sensor H.Shape -> M.IxMap Obj -> IO (Maybe Event)
  getTouch touch objs = do
      val <- getSensor touch 
      maybe (return Nothing) handleJust val
      where hasShape s obj = s == objShape obj
            handleJust :: H.Shape -> IO (Maybe Event)
            handleJust x = maybe (return Nothing) 
                      (fmap (Just . Touch) . uncurry obj2ball)
                      $ find (hasShape x . snd) (M.toList objs)  
  
  getClick    :: Sensor H.Position -> IO (Maybe Event)
  getClick = fmap (fmap UserClick) . getSensor
  
  getSensor :: Sensor a -> IO (Maybe a)
  getSensor ref = do
      val <- get ref
      maybe (return Nothing) handleJust val
      where handleJust a = do
                  ref $= Nothing
                  return $ Just a
  
  
  removeBall      :: Ball         -> Dirty -> IO Dirty
  heroVelocity    :: H.Velocity   -> Dirty -> IO Dirty
  makeBall        :: Freq         -> Dirty -> IO Dirty
  gameOver        ::                 Dirty -> IO Dirty 
  
  ----------------------------
  
  gameOver = const $ initDirty
  
  removeBall b d = do
      
      H.spaceRemove space $ objBody obj
      H.spaceRemove space $ objShape obj
      return $ d{ dirtyObjs = M.delete k $ dirtyObjs d }
      where k     = ballId b
            obj   = dirtyObjs d M.! k
            space = dirtySpace d
  
  heroVelocity vel a = ((objVel $ dirtyHero a) $= vel) >> return a
  
  makeBall f a = do 
      obj <- genBall f (dirtySpace a)
      return $ a{ dirtyObjs = fst $ M.insert obj (dirtyObjs a) }
  
  genBall :: Freq -> H.Space -> IO Obj
  genBall f space = do
      bType   <- genBallType f
      (p, v)  <- genBallState
      ball    <- initObj bType p v space
      return ball
   
  
  
  genBallType :: Freq -> IO BallType
  genBallType f = R.evalRandIO $ R.fromList $ [
              (Good,  toRational $ freqGood f), 
              (Bad,   toRational $ freqBad f),
              (Bonus, toRational $ freqBonus f)]
  
  
  genBallState :: IO (H.Position, H.Vector)
  genBallState = do
      n   <- randomRIO (0, 5)
      dx  <- randomRIO (-1.0, 1.0)
      dy  <- randomRIO (-1.0, 1.0)
      dv  <- genBallVelocity 
  
      let p = holePoints !! n
      return (p, vel (getAngle dx dy p) dv)
      where vel a len = H.scale a len
  
            getAngle dx dy p = H.normalize $ (vec h2 w2) - p
              where w2 = dx * frameWidth/3
                    h2 = dy * frameHeight/3  
  
  
  genBallVelocity :: IO H.CpFloat
  genBallVelocity = randomRIO (minBallVel, maxBallVel)
      
  
  ------------------------------------------------------------
  -- init
  
  initDirty :: IO Dirty
  initDirty = do
      space       <- initSpace
      hero        <- initHero space
      touchVar    <- initSensor (touchCallback space)
      mouseVar    <- initSensor mouseCallback
  
      return $ Dirty 
              { dirtyHero     = hero
              , dirtyObjs     = M.empty
              , dirtySpace    = space
              , dirtyTouchVar = touchVar 
              , dirtyMouse    = mouseVar
              }
  
  initSensor :: (Sensor a -> IO ()) -> IO (Sensor a)
  initSensor callback = do
      var <- newIORef Nothing
      callback var
      return var
  
  
  initSpace :: IO H.Space
  initSpace = do    
      space <- H.newSpace
      initWalls space
      return space
  
  touchCallback :: H.Space -> Sensor H.Shape -> IO ()
  touchCallback space touchVar = do
      H.addCollisionHandler space 
          (toCollisionType Hero) (toCollisionType Good) handler
      where handler = H.Handler Nothing Nothing (Just handle) Nothing
  
            handle = do
              (a, b) <- H.shapes
              liftIO $ touchVar $= (Just b)
  
  
  mouseCallback :: Sensor H.Position -> IO ()
  mouseCallback sensor = do      
      G.mouseButtonCallback $= (onMouse (updatePos sensor))
      where updatePos sensor =  do
                  pos <- get G.mousePos
                  size <- get G.windowSize
                  sensor $= Just (mouse2canvas size pos)
  
  onMouse act key keyState = case (key, keyState) of
      (G.ButtonLeft, G.Press)  -> act
      _                        -> return ()
  
  
  mouse2canvas :: G.Size -> G.Position -> H.Vector
  mouse2canvas (G.Size sx sy) (G.Position mx my) = H.Vector x y
      where d a b  = fromIntegral a / fromIntegral b
            x  = windowWidth * (d mx sx - 0.5)
            y  = windowHeight * (negate $ d my sy - 0.5)
  
  
  initHero :: H.Space -> IO Obj
  initHero = initObj Hero (vec 0 0) (vec 0 0)
  
  initObj :: BallType -> H.Position -> H.Vector -> H.Space -> IO Obj
  initObj ballType pos vel space = do
      b <- H.newBody mass $ H.momentForCircle mass (0, radius) 0
      s <- H.newShape b (H.Circle radius) 0
      H.position b $= pos
      H.velocity b $= vel
      
      H.elasticity s $= 0.9999
      H.collisionType s $= toCollisionType ballType
  
      H.spaceAdd space b 
      H.spaceAdd space s
  
      return $ (Obj ballType s b)
      where mass      = 20
            radius    = ballRadius
  
  
  toCollisionType :: BallType -> Word32
  toCollisionType a = case a of
      Hero    -> 1
      _       -> 2
  
  
  initWalls :: H.Space -> IO ()
  initWalls space = mapM_ f wallPoints
      where f (a, b) = initWall a b space
  
  
  initWall :: H.Position -> H.Position -> H.Space -> IO ()
  initWall pa pb space = do    
      b <- H.newBody H.infinity H.infinity
      s <- H.newShape b (H.LineSegment pa pb wallThickness) 0
      H.elasticity s $= 0.9999
      H.spaceAdd space b
      H.spaceAdd space s
      return ()
    
  
  