From 394f4b4df1049339e561726390c202bb41749d7f Mon Sep 17 00:00:00 2001 From: techieAgnostic Date: Sun, 19 May 2019 18:11:40 +1200 Subject: [PATCH] compiles --- Connect.hs | 51 +++++++++++++++++++++++++++++++++++---------------- Group.hs | 41 +++++++++++++++++++++++------------------ Init.hs | 29 ----------------------------- State.hs | 27 ++------------------------- Types.hs | 11 +++++------ Util.hs | 6 ++++-- 6 files changed, 69 insertions(+), 96 deletions(-) delete mode 100644 Init.hs diff --git a/Connect.hs b/Connect.hs index 91d4585..06babc6 100644 --- a/Connect.hs +++ b/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 - | isDowned charX oldDowned = oldBoardState +conHurt charX charY oldBoardState + | not $ isAdjacent charX charY oldGroups = 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") + ++ [ Right (show charX ++ " is not adjacent to " ++ show 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 - , ntDowned = (charY:oldDowned) + { ntPutCards = filter (\x -> ((fst x) /= Left charX)) oldPut + , 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 - oldGroups = (ntGroups . bsNeoTokyo) oldBS - oldPut = (ntPutCards . bsNeoTokyo) oldBS + 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 diff --git a/Group.hs b/Group.hs index f8d1b5d..56efefb 100644 --- a/Group.hs +++ b/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) diff --git a/Init.hs b/Init.hs deleted file mode 100644 index 9c1bd54..0000000 --- a/Init.hs +++ /dev/null @@ -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 - } diff --git a/State.hs b/State.hs index 6002116..51a0210 100644 --- a/State.hs +++ b/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 - - diff --git a/Types.hs b/Types.hs index 8e9706e..1fdd0ff 100644 --- a/Types.hs +++ b/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 diff --git a/Util.hs b/Util.hs index dc2162b..f523e82 100644 --- a/Util.hs +++ b/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 +