making nice connections

Connect.hs

@@ -0,0 +1,33 @@
+module Connect where
+
+import Types
+import Util
+
+-- Passes state for X to hurt Y
+conHurt :: MainCharacter -> MainCharacter -> BoardState -> BoardState
+conHurt charX charY oldBS
+   | isDowned charX oldDowned = oldBoardState
+      { bsGameLog = (bsGameLog oldBoardState)
+         ++ $ Right GameError (charX ++ " is downed, could not hurt " ++ charY)
+      }
+   | (isAdjacent . not) charX charY oldGroups = oldBoardState
+      { bsGameLog = (bsGameLog oldBoardState)
+         ++ $ Right GameError (charX ++ " is not adjacent to " ++ charY ++ ", could not hurt")
+      }
+   | isAlone charX oldGroups = oldBoardState
+      { bsGameLog = (bsGameLog oldBoardState)
+         ++ $ Left GameLine (charX ++ " hurt " ++ charY ++ ", " ++ charY ++ " is downed")
+      , bsNeoTokyo = (bsNeoTokyo oldBoardState)
+         { ntPutCards = filter (\x -> filter ((snd x) /= Just charX)) oldPut
+         , ntDowned = (charY:oldDowned)
+         }
+   |otherwise = oldBoardState
+      { bsGameLog = (bsGameLog oldBoardState)
+         ++ $ Left GameLine (charX ++ " hurt " ++ charY ++ ", " ++ charY ++ " left their group")
+      , bsNeoTokyo = (bsNeoTokyo oldBoardState)
+         { ntGroups = removeFromGroup charY oldGroups }
+      }  
+   where
+      oldDowned = (ntDowned . bsNeoTokyo) oldBS
+      oldGroups = (ntGroups . bsNeoTokyo) oldBS
+      oldPut = (ntPutCards . bsNeoTokyo) oldBS

Group.hs

@@ -15,28 +15,45 @@ defFrens Misato = [Asuka, Shinji, Ritsuko]
 defFrens Ritsuko = [Misato, Shinji, Gendo]
 defFrens Gendo = [Rei, Shinji, Ritsuko]
 
--- The group that character x belongs to
+-- Return true if charater is downed
-charsGroup :: MainCharacter -> NeoTokyo -> Group
+isDowned :: MainCharacter -> Downed -> Bool
-charsGroup x nt = head $ filter (\g -> x `elem` g) nt
+isDowned c d = c `elem` d
 
--- The characters currently grouped with x
+-- Return true if character is not grouped
-curFrens :: MainCharacter -> NeoTokyo -> [MainCharacter]
+isAlone :: MainCharacter -> Groups -> Bool
-curFrens x nt = filter (/= x) $ charsGroup x nt
+isAlone c g = curFrens c g == []
 
--- The groups a character is adaject to
+-- Return true if X is adjacent to Y
-adjGroups :: MainCharacter -> NeoTokyo -> [Group]
+isAdjacent :: MainCharacter -> MainCharacter -> Groups -> Bool
-adjGroups x nt = filter (\g -> any (\x -> x `elem` adjFrens) g) (otherGroups x nt)
+isAdjacent x y g = y `elem` $ getAdj x g
-   where
-      adjFrens = uniq $ foldr (++) [] (map defFrens $ charsGroup x nt)
-
--- The groups a character isnt in
-otherGroups :: MainCharacter -> NeoTokyo -> [Group]
-otherGroups x nt = filter (\g -> not $ x `elem` g) nt
 
 -- All characters a X is adjacent to
-getAdj :: MainCharacter -> NeoTokyo -> [MainCharacter]
+getAdj :: MainCharacter -> Groups -> [MainCharacter]
-getAdj x nt = curFrens x nt ++ (foldr (++) [] (adjGroups x nt))
+getAdj x g = curFrens x g ++ (foldr (++) [] (adjGroups x g))
 
+-- The characters currently grouped with x
+curFrens :: MainCharacter -> Groups -> [MainCharacter]
+curFrens x g = filter (/= x) $ charsGroup x g
+
+-- The group that character x belongs to
+charsGroup :: MainCharacter -> Groups -> Group
+charsGroup x g = head $ filter (\y -> x `elem` y) g
+
+-- The groups a character isnt in
+otherGroups :: MainCharacter -> Groups -> Groups
+otherGroups x g = filter (\y -> not $ x `elem` y) g
+
+-- The groups a character is adaject to
+adjGroups :: MainCharacter -> Groups -> Groups
+adjGroups x g = filter (\y -> any (\z -> z `elem` adjFrens) y) (otherGroups x g)
+   where
+      adjFrens = uniq $ foldr (++) [] (map defFrens $ charsGroup x g)
+
+-- Return the groups with C removed from its current group
+removeFromGroup :: MainCharacter -> Groups -> Groups
+removeFromGroup c g = ( [c] : (groupMinusChar c) : (otherGroups y g) )
+
+{--
 -- X hurts Y (only if adjacent)
 hurt :: MainCharacter -> MainCharacter -> BoardState -> BoardState
 hurt x y (nt,d)
@@ -64,3 +81,4 @@ attract' :: MainCharacter -> MainCharacter -> BoardState -> BoardState
 attract' x y (nt,d) 
          | x `elem` d = (nt, (filter (/= x) d))
          | otherwise = ((uniq (charsGroup x nt ++ charsGroup y nt)) : (otherGroups y (otherGroups x nt)), d)
+--}

Types.hs

@@ -11,7 +11,13 @@ type CardLib = [(CardSym, CardInfo)]
 type Downed = [MainCharacter]
 type PutCards = [(Either MainCharacter MainEva, CardSym)]
 type CardStack = [(PlayerId, CardSym)]
-type NeoTokyo = ([Group], Evas, Angels, PutCards, Downed)
+type NeoTokyo =
+   { ntGroups :: Groups
+   , ntEvas :: Evas
+   , ntAngels :: Angels
+   , ntPutCards :: PutCards
+   , ntDowned :: Downed
+   )
 type Evas = [MainEvas]
 type Group = [MainCharacter]
 type Angels = [Angel]
@@ -22,6 +28,7 @@ type BoardState =
    , bsPriorityPlayer :: PriorityPlayer
    , bsCardStack :: CardStack
    , bsCardLib :: CardLib
+   , bsGameLog :: GameLog
    }
 
 type PlayerLib = [(PlayerId, PlayerState)]

Util.hs

@@ -21,3 +21,8 @@ uniq x = reverse $ go x []
       go [] al = al
       go (c:cs) al = if (c `elem` al) then (go cs al) else (go cs (c:al))
 
+-- Return the first item that f returns true for
+getFirstMatch :: [a] -> (a -> Bool) -> [a]
+getFirstMatch (l:ls) f
+   | f l = l
+   | otherwise = getFirstMatch ls f