compiles
This commit is contained in:
parent
7c98b61b95
commit
394f4b4df1
51
Connect.hs
51
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
|
||||
|
||||
41
Group.hs
41
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)
|
||||
|
||||
29
Init.hs
29
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
|
||||
}
|
||||
27
State.hs
27
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
|
||||
|
||||
|
||||
|
||||
11
Types.hs
11
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
|
||||
|
||||
6
Util.hs
6
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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user