evac/Connect.hs

module Connect where

import Types
import Groups

-- Passes state for X to hurt Y
conHurt :: MainCharacter -> MainCharacter -> BoardState -> BoardState
conHurt charX charY oldBoardState
   | not $ isAdjacent charX charY oldGroups = oldBoardState
      { bsGameLog = (bsGameLog oldBoardState)
         ++ [ Right (show charX ++ " is not adjacent to " ++ show charY ++ ", could not hurt") ]
      }
   | isAlone charX oldGroups = oldBoardState
      { bsGameLog = (bsGameLog oldBoardState)
         ++ [ Left (show charX ++ " hurt " ++ show charY ++ ", " ++ show charY ++ " is downed") ]
      , bsNeoTokyo = (bsNeoTokyo oldBoardState)
         { ntPutCards = filter (\x -> ((fst x) /= Left charX)) oldPut
         , ntDowned = downChar charY oldDowned
         }
      }
   | otherwise = oldBoardState
      { bsGameLog = (bsGameLog oldBoardState)
         ++ [ Left (show charX ++ " hurt " ++ show charY ++ ", " ++ show charY ++ " left their group") ]
      , bsNeoTokyo = (bsNeoTokyo oldBoardState)
         { ntGroups = removeFromGroup charY oldGroups }
      }  
   where
      oldDowned = (ntDowned . bsNeoTokyo) oldBoardState
      oldGroups = (ntGroups . bsNeoTokyo) oldBoardState
      oldPut = (ntPutCards . bsNeoTokyo) oldBoardState

conAttract :: MainCharacter -> MainCharacter -> BoardState -> BoardState
conAttract charX charY oldBoardState
   | not $ isAdjacent charX charY oldGroups = oldBoardState
      { bsGameLog = (bsGameLog oldBoardState)
         ++ [ Right (show charX ++ " is not adjacent to " ++ show charY ++ ", could not attract") ]
      }
   | isAlone charX oldGroups = oldBoardState
      { bsGameLog = (bsGameLog oldBoardState)
         ++ [ Left (show charX ++ " attracted " ++ show charY ++ ", " ++ show charY ++ " is ready") ]
      , bsNeoTokyo = (bsNeoTokyo oldBoardState)
         { ntDowned = readyChar charY oldDowned }
      }
   | otherwise = oldBoardState
      { bsGameLog = (bsGameLog oldBoardState)
         ++ [ Left (show charX ++ " attracted " ++ show charY ++ ", " ++ show charY ++ "'s group joined " ++ show charX ++ "'s group") ]
      , bsNeoTokyo = (bsNeoTokyo oldBoardState)
         { ntGroups = joinGroups charX charY oldGroups }
      }  
   where
      oldDowned = (ntDowned . bsNeoTokyo) oldBoardState
      oldGroups = (ntGroups . bsNeoTokyo) oldBoardState