compiles

Connect.hs

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

Group.hs

@@ -25,7 +25,7 @@ isAlone c g = curFrens c g == []
 
 -- Return true if X is adjacent to Y
 isAdjacent :: MainCharacter -> MainCharacter -> Groups -> Bool
-isAdjacent x y g = y `elem` $ getAdj x g
+isAdjacent x y g = y `elem` (getAdj x g)
 
 -- All characters a X is adjacent to
 getAdj :: MainCharacter -> Groups -> [MainCharacter]
@@ -51,25 +51,30 @@ adjGroups x g = filter (\y -> any (\z -> z `elem` adjFrens) y) (otherGroups 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) )
+removeFromGroup c g = ( [c] : (groupMinusChar c) : (otherGroups c g) )
+   where
+      groupMinusChar x = curFrens x g
+
+-- Return the groups with X grouped with Y
+joinGroups :: MainCharacter -> MainCharacter -> Groups -> Groups
+joinGroups x y g
+   | x `elem` curFrens y g = g
+   | otherwise = (groupX ++ groupY) : (otherGroups x g)
+   where
+      groupX = charsGroup x g
+      groupY = charsGroup y g
+
+-- Return the Downed with the new character
+downChar :: MainCharacter -> Downed -> Downed
+downChar c d
+   | c `elem` d = d
+   | otherwise = (c : d)
+
+-- Return the Downed minus the chosen character
+readyChar :: MainCharacter -> Downed -> Downed
+readyChar c d = filter (/= c) d
 
 {--
--- X hurts Y (only if adjacent)
-hurt :: MainCharacter -> MainCharacter -> BoardState -> BoardState
-hurt x y (nt,d)
-      | not $ y `elem` (getAdj x nt) = (nt,d)
-      | otherwise = hurt' x y (nt,d)
-
--- X hurts Y (no restrictions)
-hurt' :: MainCharacter -> MainCharacter -> BoardState -> BoardState
-hurt' x y (nt,d)
-      | y `elem` d = if (curFrens y nt == [])
-                       then (nt, d)
-                       else ([y] : (groupMinusChar y) : (otherGroups y nt), d)
-      | otherwise = (nt, y:d)
-   where
-      groupMinusChar y = (filter (/= y) $ charsGroup y nt)
-
 -- Attract X and Y (only if adjacent)
 attract :: MainCharacter -> MainCharacter -> BoardState -> BoardState
 attract x y (nt,d)

Init.hs

@@ -1,29 +0,0 @@
-module Init where
-
-import Types
-import Cards
-
-p1 :: Player
-p1 = ("Shaun", [S01_Shinji, S02_Asuka, S02_Asuka, S04_Misato, S05_Ritsuko, S06_Gendo], [])
-
-p2 :: Player
-p2 = ("James", [S01_Shinji, S03_Rei, S03_Rei, S04_Misato], [])
-
-bs1 :: BoardState
-bs1 = BoardState
-   { bsNeoTokyo =
-      ( [[Shinji], [Asuka], [Rei], [Misato], [Ritsuko], [Gendo]]
-      , [UnitZero, UnitOne, UnitTwo]
-      , []
-      , []
-      , []
-      )
-   , bsPlayerLib =
-      [ (1, p1)
-      , (2, p2)
-      ]
-   , bsActivePlayers = [1, 2]
-   , bsPriorityPlayer = 1
-   , bsCardStack = []
-   , bsCardLib = gCardLib
-   }

State.hs

@@ -1,5 +1,7 @@
 module State where
 
+import Types
+
 defCharsFaction :: Faction -> MainCharacter
 defCharsFaction Blue = Shinji
 defCharsFaction Red = Asuka
@@ -7,28 +9,3 @@ defCharsFaction White = Rei
 defCharsFaction Green = Misato
 defCharsFaction Yellow = Ritsuko
 defCharsFaction Black = Gendo
-
-numPut :: Either MainCharacter MainEva -> PutCards -> Integer
-numPut c p = toInteger $ length $ filter (\x -> (fst x) == c) p
-
-removeHand :: CardSym -> Player -> Either Player GameError
-removeHand c p@(n, h, d)
-   | not $ c `elem` h = Right "Card not in hand"
-   | otherwise = Left (n, nh, nd)
-      where
-         nh = rmFirstMatch h (== c)
-         nd = (c:d)
-
-playChar :: Player -> CardSym -> BoardState -> Either BoardState GameError
-playChar p@(on, oh, od) c ob@(cl, ps, d, pc)
-   | ciType (getCardInfo c cl) /= Character = Right "Not a character"
-   | numPut (Left targetChar) pc >= 2 = Right "Too many put cards"
-   | targetChar `elem` d = Right "Character is down"
-   | isRight np = Right $ unwrapRight np
-   | otherwise = Left $ (cl, (unwrapLeft np):(rmFirstMatch ps (\(n, _, _) -> n == on)), d, npc)
-      where
-         targetChar = defCharsFaction $ ciFaction (getCardInfo c cl)
-         np = removeHand c p
-         npc = (Left targetChar, c):pc
-
-

Types.hs

@@ -1,7 +1,5 @@
 module Types where
 
-import Cards
-
 data MainCharacter = Shinji | Asuka | Rei | Misato | Ritsuko | Gendo deriving (Show, Eq)
 data MainEva = UnitZero | UnitOne | UnitTwo deriving (Show, Eq)
 data Angel = Sachiel | Shamshel | Ramiel | Gaghiel | Israfel | Sandalphon | Matariel | Sahaquiel | Ireul | Leliel | Bardiel | Zeruel | Arael | Armisael | Kaworu | Man | Lilith | Adam
@@ -11,17 +9,18 @@ type CardLib = [(CardSym, CardInfo)]
 type Downed = [MainCharacter]
 type PutCards = [(Either MainCharacter MainEva, CardSym)]
 type CardStack = [(PlayerId, CardSym)]
-type NeoTokyo =
+data NeoTokyo = NeoTokyo
    { ntGroups :: Groups
    , ntEvas :: Evas
    , ntAngels :: Angels
    , ntPutCards :: PutCards
    , ntDowned :: Downed
-   )
+   }
-type Evas = [MainEvas]
+type Evas = [MainEva]
 type Group = [MainCharacter]
+type Groups = [Group]
 type Angels = [Angel]
-type BoardState =
+data BoardState = BoardState
    { bsNeoTokyo :: NeoTokyo
    , bsPlayerLib :: PlayerLib
    , bsActivePlayers :: ActivePlayers

Util.hs

@@ -22,7 +22,9 @@ uniq x = reverse $ go x []
       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 :: [a] -> (a -> Bool) -> Maybe a
+getFirstMatch [] _ = Nothing
 getFirstMatch (l:ls) f
-   | f l = l
+   | f l = Just l
    | otherwise = getFirstMatch ls f
+