257 lines
8.1 KiB
Haskell
257 lines
8.1 KiB
Haskell
module State where
|
|
|
|
import Data.Either
|
|
|
|
data Faction = Blue | Red | White | Green | Yellow | Black deriving (Show)
|
|
data TypeSym = Character | Eva | Angel | Drama | Put | Intstrumentality deriving (Show, Eq)
|
|
data Trait = Other | Reaction | Male | Female | Weapon deriving (Show)
|
|
data MainCharacter = Shinji | Asuka | Rei | Misato | Ritsuko | Gendo deriving (Show, Eq)
|
|
data MainEva = UnitZero | UnitOne | UnitTwo deriving (Show, Eq)
|
|
data CardSym = S01_Shinji | S02_Asuka | S03_Rei | S04_Misato | S05_Ritsuko | S06_Gendo deriving (Show, Eq)
|
|
data Mark = Circle | Triangle deriving (Show)
|
|
|
|
type CardLib = [(CardSym, CardInfo)]
|
|
type Traits = [Trait]
|
|
type Hand = [CardSym]
|
|
type Discard = [CardSym]
|
|
type PlayerName = String
|
|
type Player = (PlayerName, Hand, Discard)
|
|
type Players = [Player]
|
|
type LineMark = (Mark, Faction)
|
|
type LineMarks = [LineMark]
|
|
type PutCards = [(Either MainCharacter MainEva, CardSym)]
|
|
type Downed = [MainCharacter]
|
|
type BoardState = (CardLib, Players, Downed, PutCards)
|
|
type GameError = String
|
|
|
|
getCardInfo :: CardSym -> CardLib -> CardInfo
|
|
getCardInfo c cl = snd $ head $ filter (\(s, _) -> s == c) cl
|
|
|
|
defCharsFaction :: Faction -> MainCharacter
|
|
defCharsFaction Blue = Shinji
|
|
defCharsFaction Red = Asuka
|
|
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
|
|
|
|
rmFirstMatch :: [a] -> (a -> Bool) -> [a]
|
|
rmFirstMatch [] _ = []
|
|
rmFirstMatch (l:ls) f
|
|
| f l = ls
|
|
| otherwise = (l : rmFirstMatch ls f)
|
|
|
|
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
|
|
|
|
unwrapLeft :: Either a b -> a
|
|
unwrapLeft (Left x) = x
|
|
unwrapLeft (Right _) = error "Not a Left value"
|
|
|
|
unwrapRight :: Either a b -> b
|
|
unwrapRight (Right x) = x
|
|
unwrapRight (Left _) = error "Not a Right value"
|
|
|
|
p1 :: Player
|
|
p1 = ("Shaun", [S01_Shinji, S02_Asuka, S03_Rei, S04_Misato, S05_Ritsuko, S06_Gendo], [])
|
|
|
|
gCardLib :: CardLib
|
|
gCardLib =
|
|
[ (S01_Shinji, ciS01_Shinji)
|
|
, (S02_Asuka, ciS02_Asuka)
|
|
, (S03_Rei, ciS03_Rei)
|
|
, (S04_Misato, ciS04_Misato)
|
|
, (S05_Ritsuko, ciS05_Ritsuko)
|
|
, (S06_Gendo, ciS06_Gendo)
|
|
]
|
|
|
|
data CardInfo = CardInfo
|
|
{ ciName :: String
|
|
, ciFaction :: Faction
|
|
, ciType :: TypeSym
|
|
, ciText :: String
|
|
, ciTraits :: Traits
|
|
, ciLineMarks :: Maybe LineMarks
|
|
, ciLine :: Maybe String
|
|
, ciDP :: Maybe Integer
|
|
, ciStrength :: Maybe Integer
|
|
, ciLevel :: Maybe Integer
|
|
, ciNextInst :: Maybe CardSym
|
|
} deriving (Show)
|
|
|
|
ciS01_Shinji = CardInfo
|
|
{ ciName = "3rd Child - Shinji Ikari"
|
|
, ciFaction = Blue
|
|
, ciType = Character
|
|
, ciText = "Can speak one blue card every turn."
|
|
, ciTraits = [Male]
|
|
, ciLineMarks = Just [(Circle, Blue)]
|
|
, ciLine = Just "I feel like I belong here!"
|
|
, ciDP = Just 0
|
|
, ciStrength = Nothing
|
|
, ciLevel = Nothing
|
|
, ciNextInst = Nothing
|
|
}
|
|
|
|
ciS02_Asuka = CardInfo
|
|
{ ciName = "2nd Child - Asuka Langley-Soryu"
|
|
, ciFaction = Red
|
|
, ciType = Character
|
|
, ciText = "Can speak one red card every turn."
|
|
, ciTraits = [Female]
|
|
, ciLineMarks = Just [(Triangle, Blue), (Triangle, Green), (Triangle, Yellow)]
|
|
, ciLine = Just "What're you, stupid?!"
|
|
, ciDP = Just 1
|
|
, ciStrength = Nothing
|
|
, ciLevel = Nothing
|
|
, ciNextInst = Nothing
|
|
}
|
|
|
|
ciS03_Rei = CardInfo
|
|
{ ciName = "1st Child - Rei Ayanami"
|
|
, ciFaction = White
|
|
, ciType = Character
|
|
, ciText = "Can speak one white card every turn. All white lines are zero DP. If down at the start of the Opening Draw phase, Rei recovers automatically."
|
|
, ciTraits = [Female]
|
|
, ciLineMarks = Just [(Circle, White)]
|
|
, ciLine = Just "I feel connected."
|
|
, ciDP = Just (-1)
|
|
, ciStrength = Nothing
|
|
, ciLevel = Nothing
|
|
, ciNextInst = Nothing
|
|
}
|
|
|
|
ciS04_Misato = CardInfo
|
|
{ ciName = "Misato Katsuragi"
|
|
, ciFaction = Green
|
|
, ciType = Character
|
|
, ciText = "Can speak one green card every turn."
|
|
, ciTraits = [Female]
|
|
, ciLineMarks = Just [(Circle, Green)]
|
|
, ciLine = Just "We can't wait for a miracle, let's give it our best shot."
|
|
, ciDP = Just 0
|
|
, ciStrength = Nothing
|
|
, ciLevel = Nothing
|
|
, ciNextInst = Nothing
|
|
}
|
|
|
|
ciS05_Ritsuko = CardInfo
|
|
{ ciName = "Ritsuko Akagi"
|
|
, ciFaction = Yellow
|
|
, ciType = Character
|
|
, ciText = "Can speak one yellow card every turn."
|
|
, ciTraits = [Female]
|
|
, ciLineMarks = Just [(Circle, Yellow)]
|
|
, ciLine = Just "The one Unit Zero was after was me."
|
|
, ciDP = Just 0
|
|
, ciStrength = Nothing
|
|
, ciLevel = Nothing
|
|
, ciNextInst = Nothing
|
|
}
|
|
|
|
ciS06_Gendo = CardInfo
|
|
{ ciName = "Gendo Ikari"
|
|
, ciFaction = Black
|
|
, ciType = Character
|
|
, ciText = "Can speak one black card every turn."
|
|
, ciTraits = [Male]
|
|
, ciLineMarks = Just [(Circle, Black)]
|
|
, ciLine = Just "There is no problem."
|
|
, ciDP = Just (-1)
|
|
, ciStrength = Nothing
|
|
, ciLevel = Nothing
|
|
, ciNextInst = Nothing
|
|
}
|
|
|
|
{--
|
|
module Groups where
|
|
|
|
import State
|
|
|
|
-- Each characters default adjacents
|
|
defFrens :: MainCharacter -> [MainCharacter]
|
|
defFrens Asuka = [Rei, Shinji, Misato]
|
|
defFrens Shinji = [Rei, Gendo, Ritsuko, Misato, Asuka]
|
|
defFrens Rei = [Gendo, Shinji, Asuka]
|
|
defFrens Misato = [Asuka, Shinji, Ritsuko]
|
|
defFrens Ritsuko = [Misato, Shinji, Gendo]
|
|
defFrens Gendo = [Rei, Shinji, Ritsuko]
|
|
|
|
-- The group that character x belongs to
|
|
charsGroup :: MainCharacter -> NeoTokyo -> Group
|
|
charsGroup x nt = head $ filter (\g -> x `elem` g) nt
|
|
|
|
-- The characters currently grouped with x
|
|
curFrens :: MainCharacter -> NeoTokyo -> [MainCharacter]
|
|
curFrens x nt = filter (/= x) $ charsGroup x nt
|
|
|
|
-- Remove duplicates, stabily
|
|
uniq :: (Eq a) => [a] -> [a]
|
|
uniq x = reverse $ go x []
|
|
where
|
|
go [] al = al
|
|
go (c:cs) al = if (c `elem` al) then (go cs al) else (go cs (c:al))
|
|
|
|
-- The groups a character is adaject to
|
|
adjGroups :: MainCharacter -> NeoTokyo -> [Group]
|
|
adjGroups x nt = filter (\g -> any (\x -> x `elem` adjFrens) g) (otherGroups x nt)
|
|
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 x nt = curFrens x nt ++ (foldr (++) [] (adjGroups x nt))
|
|
|
|
-- 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)
|
|
| not $ y `elem` (getAdj x nt) = (nt,d)
|
|
| otherwise = attract' x y (nt,d)
|
|
|
|
-- Attract X and Y (no restrictions)
|
|
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)
|
|
--}
|