module Pure where
import Data.Monoid
import Data.Maybe
import qualified Physics.Hipmunk as H
import Control.Monad.State
import Control.Applicative
import Data.Tuple(swap)
import Data.List
import Types
import Utils
import Inits
import Graphics
pureGameOver :: Pure -> Bool
pureGameOver s = case pureGameState s of
On -> False
_ -> True
processClick :: Pure -> (Pure, [Query])
processClick p = case pureGameState p of
WaitForClick 0 -> (reset p, [GameOver])
WaitForClick n -> (p{ pureGameState = WaitForClick (n-1) }, [])
On -> (p, [])
------------------------------------------------------------------
-- inits
initPure :: Sense -> [Event] -> Pure
initPure sense _ = Pure
{ pureScores = initScores
, pureHero = senseHero sense
, pureBalls = senseBalls sense
, pureCreation = initCreation
, pureTouch = Nothing
, pureGameState = On
}
initScores = Scores
{ scoresLevel = 0
, scoresLives = livesNum
, scoresBonus = 0
}
initCreation = Creation
{ creationStat = Stat 0 0 0
, creationGoalStat = Stat goodBallCount badBallCount bonusBallCount
, creationTick = 0
}
-------------------------------------------------------------------
-- events
-- continuous
updateSenses :: Sense -> Pure -> Pure
updateSenses sense pure
| pureGameOver pure = pure
| otherwise = pure
{ pureHero = senseHero sense
, pureBalls = senseBalls sense
, pureCreation= creation{ creationStat = getStat $ senseBalls sense }
, pureTouch = updTouch =<< pureTouch pure
}
where creation = pureCreation pure
getStat = foldl' phi (Stat 0 0 0) . fmap ballType
phi stat b = case b of
Good -> stat{ goodCount = succ $ goodCount stat }
Bad -> stat{ badCount = succ $ badCount stat }
Bonus -> stat{ bonusCount = succ $ bonusCount stat }
Hero -> stat
updTouch (n, xs) = case n of
0 -> Nothing
a -> Just (pred a, xs)
-- discrete
updateEvents :: [Event] -> Pure -> (Pure, [Query])
updateEvents evts pure
| pureGameOver pure = onGameOver evts pure
| otherwise = upd pure
where upd = swap . runState
(concat <$> liftA2 (:) onNothing (mapM onEvent evts))
onGameOver :: [Event] -> Pure -> (Pure, [Query])
onGameOver evts pure
| any isUserClick evts = processClick pure
| otherwise = (pure, [])
where isUserClick evt = case evt of
(UserClick _) -> True
_ -> False
onEvent :: Event -> State Pure [Query]
onEvent = foldEvent onTouch onUserClick
onUserClick :: H.Position -> State Pure [Query]
onUserClick p1 = state $ \s ->
let hero = pureHero s
v = heroVel $ pureHero s
p0 = heroPos $ pureHero s
v1 = H.scale (H.normalize (p1 - p0)) (max v minVel)
s' = s{ pureHero = hero{ heroVel = H.len v1 }}
in ([HeroVelocity v1], s')
onNothing :: State Pure [Query]
onNothing = state $ phi
where phi s
| isGameOver s = ([], setGameOver s)
| pureGameOver s = ([], s)
| tick == creationPeriod =
(Step : def ++ createBall s, setTick 0 s)
| otherwise =
(Step : def, setTick (succ tick) s)
where create = pureCreation s
tick = creationTick create
setTick a s = s{ pureCreation = create{ creationTick = a } }
def = removeOutliners s
setGameOver a = a{ pureGameState = WaitForClick 1 }
isGameOver :: Pure -> Bool
isGameOver s
= (not $ insideFrame $ heroPos $ pureHero s)
|| 0 > (scoresLives $ pureScores s)
reset :: Pure -> Pure
reset a = a
{ pureScores = initScores
, pureCreation = initCreation
, pureGameState= On }
createBall :: Pure -> [Query]
createBall st = maybeToList $ fmap MakeBall $ freq goal cur
where goal = creationGoalStat $ pureCreation st
cur = creationStat $ pureCreation st
freq :: Stat -> Stat -> Maybe Freq
freq goal cur
| isLess s = Just res
| otherwise = Nothing
where dt g = max 0 $ g goal - g cur
f g = toEnum (g s) / toEnum (total s)
isLess s = s /= (Stat 0 0 0)
s = Stat (dt goodCount) (dt badCount) (dt bonusCount)
res = Freq (f goodCount) (f badCount) (f bonusCount)
total (Stat a b c) = a + b + c
removeOutliners :: Pure -> [Query]
removeOutliners =
fmap Remove . filter (not . insideFrame . ballPos) . pureBalls
insideFrame :: H.Position -> Bool
insideFrame (H.Vector x y) = abs x <= w2 && abs y <= h2
where w2 = windowWidth / 2
h2 = windowHeight / 2
onTouch :: Ball -> State Pure [Query]
onTouch b = state $ \s -> case ballType b of
Hero -> ([], s)
Good -> ([Remove b], updLive (min livesNum . succ) s)
Bad -> ([], updLive pred s)
Bonus -> let xs = removeBonus (ballPos b) s
in (fmap Remove xs, setTouch xs $
updBonus (length xs) s)
setTouch xs s = s{ pureTouch = Just (bonusSleep, xs) }
updScores f s = s{ pureScores = f $ pureScores s }
updLive f = updScores (\a -> a{ scoresLives = f $ scoresLives a })
updCreation f = \a -> a{ pureCreation = f $ pureCreation a }
updGoalStat f = updCreation $
\a -> a{ creationGoalStat = f $ creationGoalStat a }
updBonus :: Int -> Pure -> Pure
updBonus n a
| isLevelUp level' level = updGoalStat (makeItHarder level') a'
| otherwise = a'
where (bonus', level') = countBonus n bonus level
bonus = scoresBonus sco
level = scoresLevel sco
a' = a{ pureScores = sco
{ scoresBonus = bonus'
, scoresLevel = level'} }
sco = pureScores a
isLevelUp new old = new > old
makeItHarder level a = a
{ badCount = incrBad level $ badCount a
, bonusCount = incrBonus level $ bonusCount a
, goodCount = incrGood level $ goodCount a
}
{-
updBonus f = updScores (\a ->
let (newBonus, newLevel) = f (scoresBonus a) (scoresLevel a)
in a{ scoresBonus = newBonus
, scoresLevel = newLevel
})
-}
countBonus n bonus level
| bonus' > bonusNum = (bonus' - bonusNum, level + 1)
| otherwise = (bonus', level)
where bonus' = bonus + (fromEnum $ count $ fromIntegral $ n - 1)
count x = 0.5*x*(x + 1)
removeBonus :: H.Position -> Pure -> [Ball]
removeBonus pos = filter (closeTo pos . ballPos) . pureBalls
where closeTo p1 p2 = H.len (p1 - p2) < bonusRadius
----------------------------------------------------------
-- drawing
picture :: Pure -> Picture
picture a = mconcat [
drawScores $ pureScores a,
drawWalls,
drawHero $ pureHero a,
mconcat $ fmap drawBall $ pureBalls a,
maybe mempty (drawTouch $ heroPos $ pureHero a) $ pureTouch a
]
drawHero :: HeroBall -> Picture
drawHero = drawObj Hero . heroPos
drawBall :: Ball -> Picture
drawBall b = drawObj (ballType b) (ballPos b)
drawObj objType objPos =
Prim (type2color objType) (CircleSolid (vec2point objPos) ballRadius)
where type2color a = case a of
Hero -> red
Good -> green
Bad -> blue
Bonus -> orange
drawWalls :: Picture
drawWalls = mconcat $ map f wallPoints
where f (a, b) = Prim (Color 0 0 0) $ Line (vec2point a) (vec2point b)
vec2point :: H.Vector -> Point
vec2point (H.Vector x y) = Point x y
scorePosition = Point (-frameWidth/2) (frameHeight/2 + 20)
drawScores :: Scores -> Picture
drawScores a = mconcat [
drawBonus a,
drawLives (scoresLives a)]
drawLives :: Int -> Picture
drawLives n = drawScoresRect livesRect livesNum n (col1 n) (col2 n)
where col1 n
| n <= 1 = red
| otherwise = blue
col2 n
| n <= 3 = red
| otherwise = green
drawScoresRect f lim val col1 col2 = mconcat [
Prim col2 (uncurry RectSolid $ f $
fromIntegral (max 0 val) / fromIntegral lim),
Prim col1 (uncurry Rect $ f 1) ]
drawTouch :: H.Position -> (Int, [Ball]) -> Picture
drawTouch center = (rim `mappend`) . mconcat . fmap (drawBall . toBonus) . snd
where toBonus b = b{ ballType = Bonus }
rim = Prim orange $ Circle (vec2point center) bonusRadius
drawBonus :: Scores -> Picture
drawBonus a = Prim black
(Text resultPoint $ "Bonus: " ++ (show $ totalBonus a))
totalBonus :: Scores -> Int
totalBonus a = scoresLevel a * bonusNum + scoresBonus a