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 ()