Raincat-1.1.1: src/Game/GameMain.hs
module Game.GameMain
(gameMain) where
import Data.List
import Data.Maybe
import Control.Monad.State
import Data.IORef
import qualified Graphics.UI.GLUT as Glut
import World.World
import Rain.Rain as Rain
import Nxt.Types
import Input.InputState as InputState
import Panels.MainPanel
-- import qualified Panels.MainPanel as MainPanel
import Panels.ItemPanel
import Settings.WorldSettings as WorldSettings
import Settings.DisplaySettings as DisplaySettings
import Settings.CatSettings as CatSettings
import Data.Time.Clock
import Cat.Cat
import Items.Items
import Items.ItemEffects
import Level.Level
import Level.FireHydrant
import Level.EndMarker
import Game.GameState
import Nxt.Graphics
-- gameMain
gameMain :: IORef WorldState -> (IORef WorldState -> IO ()) -> IO ()
gameMain worldStateRef mainCallback = do
startTime <- getCurrentTime
worldState <- readIORef worldStateRef
let mainpanel = mainPanel worldState
let lvl = curLevel worldState
lvlData = levelData lvl
-- get updated input
let keysRef' = keysStateRef worldState
mousePosRef' = mousePosRef worldState
mousePos' <- readIORef (mousePosRef worldState)
keys' <- readIORef (keysStateRef worldState)
Glut.Size winW winH <- Glut.get Glut.windowSize
let (mousex, mousey) = translateMousePos mousePos' winW winH
-- update camera pos
let (cameraX, cameraY) = cameraPos $ mainPanel worldState
cameraX' = if leftKeyDown keys' && cameraX < 0.0
then cameraX + WorldSettings.cameraSpeed
else
if rightKeyDown keys' && cameraX > -(fromIntegral $ levelWidth lvl :: Double) + fromGLdouble screenResWidth
then cameraX - WorldSettings.cameraSpeed
else cameraX
cameraY' = if upKeyDown keys' && cameraY > 0.0
then cameraY - WorldSettings.cameraSpeed
else
if downKeyDown keys' && cameraY < (fromIntegral $ levelHeight lvl :: Double) - fromGLdouble screenResHeight
then cameraY + WorldSettings.cameraSpeed
else cameraY
-- update rain
rain' <- updateRain worldState
-- update go/stop state
let goStopState' = if catItemName c == "Hurt" && isJust (catItemDuration c) && fromJust (catItemDuration c) == 1
then GoState
else goStopState $ goStopButton $ itemPanel worldState
where c = cat mainpanel
-- update go/stop button
let goStopBtn = updateGoStopButton (goStopButton $ itemPanel worldState)
goStopBtn' = if pointInRect (mousex, mousey) (goStopButtonRect goStopBtn) && lMouseDown keys'
then toggleGoStopButton goStopBtn
else goStopBtn {goStopState = goStopState'}
let (cat', itemL) = updateCatAndItems goStopState' mainpanel keys' (cameraX', cameraY') (mousex, mousey) lvlData
catUsedItems = itemList mainpanel \\ itemL
-- update items
(item', (itemList', corkList', tarpList'), placedItem, placingItem', erasedItems) <- updateItemList goStopState' worldState keys' (mousex, mousey) (cameraX', cameraY') itemL
-- update item constraints
let itemButList = itemButtonList $ itemPanel worldState
itemButList' = execState (do
-- placed an item in world
iBL1 <- get
put (if placedItem
then map (\itemBut -> if itemName (itemButItem itemBut) == itemName item'
then itemBut {itemButCount = itemButCount itemBut - 1}
else itemBut) iBL1
else iBL1)
-- erased an item from world
iBL2 <- get
put (if not (null erasedItems)
then foldr (\ersItemName -> map (\itemBut -> if itemName (itemButItem itemBut) == ersItemName
then itemBut {itemButCount = itemButCount itemBut + 1}
else itemBut))
iBL2 erasedItems
else iBL2)
-- cat used an item in world
iBL3 <- get
put (if not (null catUsedItems)
then foldr (\usedItem -> map (\itemBut -> if itemName (itemButItem itemBut) == itemName usedItem
then itemBut {itemButCount = itemButCount itemBut + 1}
else itemBut))
iBL3 catUsedItems
else iBL3)
return ())
itemButList
-- update fire hydrants
let _ = if catItemName cat' == "Wrench"
then foldr (\fh fhList -> if rectIntersect (catHitbox cat') (fireHydrantRect fh)
then case (fireHydrantDir fh) of
DirLeft -> if fst (catPos cat') > (rectX (fireHydrantRect fh) + rectWidth (fireHydrantRect fh))
then (fh {fireHydrantDisabled = True}):fhList
else fh:fhList
DirRight -> if fst (catPos cat') < rectX (fireHydrantRect fh)
then (fh {fireHydrantDisabled = True}):fhList
else fh:fhList
else fh:fhList)
[] (fireHydrants $ mainPanel worldState)
else fireHydrants $ mainPanel worldState
let fireHydrants' = updateFireHydrants goStopState' cat' worldState
-- update game state (menu, post victory)
let gameState' = if escKeyDown keys'
then MainMenuState
else if catItemName cat' == "Win" && isJust (catItemDuration cat') && fromJust (catItemDuration cat') == 1
then PostVictoryState
else GameRunningState
-- update panels
let mainPanel' = mainpanel {cameraPos = (cameraX', cameraY'), raindrops = rain', cat = cat', curItem = item',
itemList = itemList', corkList = corkList', tarpList = tarpList',
fireHydrants = fireHydrants', placingItem = placingItem'}
itemPanel' = (itemPanel worldState) {itemButtonList = itemButList', goStopButton = goStopBtn'}
messagePanel' <- updateMessagePanel worldState
-- update world
-- let lvl = curLevel worldState
writeIORef worldStateRef (worldState {gameState = gameState', keysStateRef = keysRef', mousePosRef = mousePosRef', mainPanel = mainPanel', itemPanel = itemPanel', messagePanel = messagePanel'})
Glut.postRedisplay Nothing
endTime <- getCurrentTime
let timeDiff = truncate (1000 * diffUTCTime endTime startTime)
timeSleep = if timeDiff < refreshMS then refreshMS - timeDiff else 0
--print timeDiff
Glut.addTimerCallback timeSleep (mainCallback worldStateRef)
-- updateFireHydrants
updateFireHydrants :: GoStopState -> Cat -> WorldState -> [FireHydrant]
updateFireHydrants GoState _ worldState =
let enabledFHs = map (\fh -> fh {fireHydrantDisabled = False}) (fireHydrants $ mainPanel worldState)
in map updateFireHydrant enabledFHs
updateFireHydrants StopState theCat worldState =
let fireHydrantsL = if catItemName theCat == "Wrench"
then foldr (\fh fhList -> if rectIntersect (catHitbox theCat) (fireHydrantRect fh)
then case (fireHydrantDir fh) of
DirLeft -> if fst (catPos theCat) > (rectX (fireHydrantRect fh) + rectWidth (fireHydrantRect fh))
then (fh {fireHydrantDisabled = True}):fhList
else fh:fhList
DirRight -> if fst (catPos theCat) < rectX (fireHydrantRect fh)
then (fh {fireHydrantDisabled = True}):fhList
else fh:fhList
else fh:fhList)
[] (fireHydrants $ mainPanel worldState)
else fireHydrants $ mainPanel worldState
in map updateFireHydrant fireHydrantsL
-- updateItemList
updateItemList :: GoStopState -> WorldState -> KeysState -> Vector2d -> Vector2d -> [Item] -> IO (Item, ([Item], [Item], [Item]), Bool, Maybe Item, [String])
-- updateItemList (StopState)
updateItemList StopState worldState _ _ _ itemL = do
let mainpanel = mainPanel worldState
posItem <- updateItem worldState
-- Note: need to force evaluation of posItem to prevent lazy evaluation of it (causes memory leak!)
let forceItemEval = posItem `seq` True
return $ if forceItemEval
then (posItem, (itemL, corkList mainpanel, tarpList mainpanel), False, Nothing, [])
else (posItem, (itemL, corkList mainpanel, tarpList mainpanel), False, Nothing, [])
-- updateItemList (GoState)
updateItemList GoState worldState keys (mousex, mousey) (camerax, cameray) itemL = do
let mainpanel = mainPanel worldState
let itemButList = itemButtonList $ itemPanel worldState
posItem <- updateItem worldState
let tempItem = if lMouseDown keys then posItem else curItem mainpanel
let item' = tempItem `seq` curItem mainpanel `seq` (if isNothing (placingItem mainpanel)
then tempItem
else curItem mainpanel)
{itemPos = (mousex - camerax - (fromIntegral $ textureWidth $ itemTexture tempItem :: Double) / 2.0,
mousey - cameray - (fromIntegral $ textureHeight $ itemTexture tempItem :: Double) / 2.0)}
let curItemIntersects = foldr ((||) . itemIntersects (curItem mainpanel))
False itemL
||
foldr ((||) . itemIntersects (curItem mainpanel))
False (corkList mainpanel)
||
foldr ((||) . itemIntersects (curItem mainpanel))
False (tarpList mainpanel)
-- remove any items if eraser was clicked on them
let ((itemListE, corkListE, tarpListE)) = if rMouseDown keys
then (filter (not . itemIntersects (curItem mainpanel)) itemL,
filter (not . itemIntersects (curItem mainpanel)) (corkList mainpanel),
filter (not . itemIntersects (curItem mainpanel)) (tarpList mainpanel))
else (itemL, corkList mainpanel, tarpList mainpanel)
erasedItems = (itemL \\ itemListE) ++ (corkList mainpanel \\ corkListE) ++ (tarpList mainpanel \\ tarpListE)
erasedItemNames = map itemName erasedItems
-- Note: need to force evaluation of item' to prevent lazy evaluation of it (causes memory leak!)
let forceItemEval = item' `seq` True
-- Make sure we have at least 1 item of this to use
let itemCountValid = itemName item' /= "Eraser" &&
foldr (\itemBut countValid -> if itemName (itemButItem itemBut) == itemName item'
then itemButCount itemBut > 0
else countValid) True itemButList
let placeItem = forceItemEval && lMousePrevDown keys && not (lMouseDown keys) && not curItemIntersects && mousex < maxWorldX && itemName item' /= "Eraser" && itemCountValid && isJust (placingItem mainpanel)
let placingItem' = if placeItem || not (lMouseDown keys)
then Nothing
else if lMouseDown keys && itemName item' /= "Eraser" && itemCountValid
then if isJust (placingItem mainpanel)
then placingItem mainpanel
else Just item'
else Nothing
-- placing new item in world
let (itemList', corkList', tarpList') = if placeItem
then case (itemName item') of
"Cork" -> (itemListE, item':corkListE, tarpListE)
"Tarp" -> (itemListE, corkListE, item':tarpListE)
"Eraser" -> (itemListE, corkListE, tarpListE)
_ -> (item':itemListE, corkListE, tarpListE)
else (itemListE, corkListE, tarpListE)
return (item', (itemList', corkList', tarpList'), placeItem, placingItem', erasedItemNames)
-- updateCatAndItems
updateCatAndItems :: GoStopState -> MainPanel -> KeysState -> (Double, Double) -> (Double, Double) -> LevelData -> (Cat, [Item])
updateCatAndItems GoState mainpanel _ _ _ lvlData =
let c = cat mainpanel
-- catTex = catTexture c
idleTex = head $ idleTextures $ catAnimations c
walkTex = walkTextures $ catAnimations c
catTex' = idleTex : walkTex
in (c {catPos = (rectX $ levelCat lvlData, rectY $ levelCat lvlData),
catTexture = catTex', catDirection = DirRight,
catVelocity = (catWalkVelX, 0.0), catItemName = "NoItem",
catItemDuration = Nothing},
itemList mainpanel)
updateCatAndItems StopState mainpanel keys (cameraX, cameraY) (mousex, mousey) _ =
let
(catVelX, catVelY) = catVelocity $ cat mainpanel
(catX, catY) = catPos $ cat mainpanel
catdirection = catDirection $ cat mainpanel
catrect = catHitbox $ cat mainpanel
catpoly = catPoly $ cat mainpanel
catitemname = catItemName $ cat mainpanel
-- update cat and world surface collisions
catTouchedRects = foldr (\rect touchedRects -> if rectIntersect rect catrect
then rect:touchedRects else touchedRects)
[] (rectSurfaces mainpanel ++ corkRects)
where corkRects = map itemRect (corkList mainpanel)
catTouchingPoly = foldr (\poly -> (polyIntersect poly catpoly ||))
False (polySurfaces mainpanel)
catTouchingSurface = not $ null catTouchedRects || catTouchingPoly
-- update cat and puddle collisions
catTouchingPuddle = foldr (\puddle -> (rectIntersect puddle catrect ||))
False (puddles mainpanel)
catBouncePogostick = catTouchingSurface && catitemname == "Pogostick"
catFallUmbrella = not catTouchingSurface && catVelY < 0.0 &&
catitemname `elem` ["Umbrella", "FallUmbrella"]
catUpsUmbrella = catitemname == "UpsUmbrellaActive" || (catTouchingPuddle && catitemname == "UpsUmbrella" && catVelY < 0.0)
-- update cat pos, direction
(catPos', catdirection') = foldr (\rect (pos, dir) -> catRectResponse pos (catVelX, catVelY) dir catrect rect)
((catX, catY), catdirection) catTouchedRects
-- horizontal ground velocity
dirNeg = case catdirection' of
DirLeft -> -1
DirRight -> 1
groundVelX = case catitemname of
"SpeedBoots" -> catSpeedVelX * dirNeg
"Skateboard" -> catSkateVelX * dirNeg
"Hurt" -> 0.0
"Win" -> 0.0
_ -> catWalkVelX * dirNeg
-- update cat velocity
catVel' = execState (do
-- gravity
(velXg, velYg) <- get
put (if catitemname /= "UpsUmbrellaActive" && catitemname /= "Hurt" && catitemname /= "Win"
then (velXg, velYg + gravity)
else (velXg, velYg))
-- touching rect surface
(velXr, velYr) <- get
put (if not $ null catTouchedRects
then (groundVelX, 0.0)
else (velXr, velYr))
-- touching poly surface
(velXp, velYp) <- get
put (if catTouchingPoly
then (groundVelX, 2.0)
else (velXp, velYp))
-- pogostick bounce
(velXpb, velYpb) <- get
put (if catBouncePogostick
then (velXpb, -catVelY)
else (velXpb, velYpb))
return ())
(catVelocity $ cat mainpanel)
-- see if cat got wet
catTouchedPuddle = foldr (\puddle touchedPuddle -> if rectIntersect puddle catrect
then Just puddle
else touchedPuddle)
Nothing (puddles mainpanel)
catTouchingRain = foldr (\rain -> (rectIntersect (rainRect rain) catrect ||))
False (raindrops mainpanel)
catTouchedFireHydrant = foldr (\fh touchedFH -> if rectIntersect (fireHydrantRect fh) catrect
then Just fh
else touchedFH)
Nothing (fireHydrants mainpanel)
catWetFromRain = catTouchingRain &&
case catitemname of
"Shield" -> False
"Poncho" -> False
"Umbrella" -> False
"FallUmbrella" -> False
_ -> True
catWetFromPuddle = isJust catTouchedPuddle &&
case catitemname of
"Shield" -> False
"UpsUmbrella" -> False
"UpsUmbrellaActive" -> False
"RainBoots" -> rectY catrect + rectHeight catrect < rectY (fromJust catTouchedPuddle) + rectHeight (fromJust catTouchedPuddle)
"Skateboard" -> rectY catrect + rectHeight catrect < rectY (fromJust catTouchedPuddle) + rectHeight (fromJust catTouchedPuddle)
_ -> True
catWetFromFireHydrant = isJust catTouchedFireHydrant &&
let fh = fromJust catTouchedFireHydrant
in if fireHydrantDisabled fh || catitemname == "Shield"
then False
else case fireHydrantDir fh of
DirLeft -> if catitemname == "Poncho"
then case catdirection of
DirLeft -> False
_ -> rectX catrect + rectWidth catrect < rectX (fireHydrantRect fh) + rectWidth (fireHydrantRect fh) / 2.0
else rectX catrect + rectWidth catrect < rectX (fireHydrantRect fh) + rectWidth (fireHydrantRect fh) / 2.0
DirRight -> if catitemname == "Poncho"
then case catdirection of
DirRight -> False
_ -> rectX catrect + rectWidth catrect < rectX (fireHydrantRect fh) + rectWidth (fireHydrantRect fh)
else rectX catrect + rectWidth catrect > rectX (fireHydrantRect fh) + 100
catIsWet = catWetFromPuddle || catWetFromRain || catWetFromFireHydrant
-- reached end marker?
catWin = rectIntersect catrect (endMarkerRect $ endMarker mainpanel)
-- update cat item effects
preEffect = execState (do
e1 <- get
put (if catBouncePogostick
then pogostickEffect2
else e1)
e2 <- get
put (if catFallUmbrella
then fallUmbrellaEffect
else e2)
e3 <- get
put (if catUpsUmbrella
then upsUmbrellaEffect2
else e3)
e4 <- get
put (if catIsWet
then hurtEffect
else e4)
e5 <- get
put (if catWin
then winEffect
else e5)
return ()) noEffect
(effect, itemL) = foldr (\item (prevEff, prevList) -> if rectIntersect (itemRect item) catrect && (itemName item `notElem` ["Cork", "Tarp"])
then (itemEffect item, prevList)
else (prevEff, item:prevList))
(preEffect, []) (itemList mainpanel)
-- update cat
cat' = execState (do
-- apply position change
c1 <- get
put (updateCatPos c1 catPos')
-- apply velocity change
c2 <- get
put (updateCatVel c2 catVel')
-- apply direction change
c3 <- get
put (c3 {catDirection = catdirection'})
-- apply item effect
c4 <- get
put (effect c4)
-- update animation
c5 <- get
put (updateCatAnim c5)
-- revert back to walking from spring boots
c6 <- get
put (if (catItemName c6 == "SpringBoots") && catTouchingSurface && catVelY < 0
then walkEffect c6
else c6)
-- revert back to walking from pogostick bounce
c7 <- get
put (if (catItemName c7 == "Pogostick") && abs catVelY <= 1.0
then walkEffect c7
else c7)
-- revert back to walking from falling umbrella
c8 <- get
put (if (catItemName c8 == "FallUmbrella") && catTouchingSurface
then walkEffect c8
else c8)
-- revert back to walking from upsidedown umbrella
c9 <- get
put (if (catItemName c9 == "UpsUmbrellaActive") && not catTouchingPuddle
then walkEffect c9
else c9)
-- update item duration
c10 <- get
put (updateCatItemDuration c10)
-- teleport cat to mouse pos (DEBUG)
c11 <- get
put (if spaceKeyDown keys
then updateCatPos c11 (mousex - cameraX, mousey - cameraY)
else c11)
return ())
(cat mainpanel)
in (cat', itemL)
-- catRectResponse
catRectResponse :: Vector2d -> Vector2d -> Direction -> Nxt.Types.Rect -> Nxt.Types.Rect -> (Vector2d, Direction)
catRectResponse (catX, catY) (catVelX, catVelY) catDir (Rect catRX catRY catRW catRH) (Rect rectx recty rectwidth rectheight) =
let displaceY = (recty + rectheight) - catY
displaceDownY = (recty + rectheight) - (catRY + catRH)
displaceX = if catVelX < 0.0
then (rectx + rectwidth) - catRX
else if catVelX > 0.0
then rectx - (catRX + catRW)
else 0.0
oppDir = case catDir of
DirLeft -> DirRight
DirRight -> DirLeft
in execState (do
-- vertical displacement
((x1, y1), d1) <- get
put (if catVelY > 0.0
then ((x1, y1 - displaceDownY), d1)
else if abs displaceY < abs displaceX
then ((x1, y1 + displaceY), d1)
else ((x1, y1), d1))
-- horizontal displacement
((x2, y2), d2) <- get
put (if (catRY + catRH < recty + rectheight && catRY >= recty) || (catRY < recty && catVelY <= 0.0)
then ((x2 + displaceX, y2), oppDir)
else ((x2, y2), d2))
return ()) ((catX, catY), catDir)