diff --git a/Cards.hs b/Cards.hs new file mode 100644 index 0000000..6e1f9b5 --- /dev/null +++ b/Cards.hs @@ -0,0 +1,100 @@ +module Cards where + +import Types + +getCardInfo :: CardSym -> CardLib -> CardInfo +getCardInfo c cl = snd $ head $ filter (\(s, _) -> s == c) cl + +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) + ] + +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 + } diff --git a/Group.hs b/Group.hs new file mode 100644 index 0000000..275d376 --- /dev/null +++ b/Group.hs @@ -0,0 +1,66 @@ +module Groups where + +import State +import Util +import Cards +import Types +import Data.Either + +-- 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 + +-- 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) diff --git a/Init.hs b/Init.hs new file mode 100644 index 0000000..9c1bd54 --- /dev/null +++ b/Init.hs @@ -0,0 +1,29 @@ +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 bc4dd45..6002116 100644 --- a/State.hs +++ b/State.hs @@ -1,49 +1,5 @@ module State where -import Data.Either - -type CardLib = [(CardSym, CardInfo)] -type BoardState = (CardLib, Players, Downed, PutCards) - -type Downed = [MainCharacter] -type PutCards = [(Either MainCharacter MainEva, CardSym)] -type CardStack = [(PlayerId, CardSym)] -type NeoTokyo = ([Group], Evas) -type Evas = [MainEvas] -type Group = [MainCharacter] -type Angels = [Angel] - -type PlayerLib = [PlayerId, PlayerState] -type ActivePlayers = [PlayerId] -type PriorityPlayer = PlayerId -type PlayerId = Integer -type PlayerState = (PlayerName, Hand, Deck, Discard) -type PlayerName = String -type Hand = [CardSym] -type Deck = [CardSym] -type Discard = [CardSym] - -type GameLog = [GameMessage] -type GameMessage = Either GameLine GameError -type GameLine = String -type GameError = String - -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 Angel = Sachiel | Shamshel | Ramiel | Gaghiel | Israfel | Sandalphon | Matariel | Sahaquiel | Ireul | Leliel | Bardiel | Zeruel | Arael | Armisael | Kaworu | Man | Lilith | Adam -data CardSym = S01_Shinji | S02_Asuka | S03_Rei | S04_Misato | S05_Ritsuko | S06_Gendo deriving (Show, Eq) -data Mark = Circle | Triangle deriving (Show) - -type Traits = [Trait] -type LineMark = (Mark, Faction) -type LineMarks = [LineMark] - -getCardInfo :: CardSym -> CardLib -> CardInfo -getCardInfo c cl = snd $ head $ filter (\(s, _) -> s == c) cl - defCharsFaction :: Faction -> MainCharacter defCharsFaction Blue = Shinji defCharsFaction Red = Asuka @@ -55,12 +11,6 @@ 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" @@ -81,193 +31,4 @@ playChar p@(on, oh, od) c ob@(cl, ps, d, pc) 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) ---} diff --git a/Types.hs b/Types.hs new file mode 100644 index 0000000..9625821 --- /dev/null +++ b/Types.hs @@ -0,0 +1,63 @@ +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 +data CardSym = S01_Shinji | S02_Asuka | S03_Rei | S04_Misato | S05_Ritsuko | S06_Gendo deriving (Show, Eq) + +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 Evas = [MainEvas] +type Group = [MainCharacter] +type Angels = [Angel] +type BoardState = + { bsNeoTokyo :: NeoTokyo + , bsPlayerLib :: PlayerLib + , bsActivePlayers :: ActivePlayers + , bsPriorityPlayer :: PriorityPlayer + , bsCardStack :: CardStack + , bsCardLib :: CardLib + } + +type PlayerLib = [(PlayerId, PlayerState)] +type ActivePlayers = [PlayerId] +type PriorityPlayer = PlayerId +type PlayerId = Integer +type PlayerState = (PlayerName, Hand, Deck, Discard) +type PlayerName = String +type Hand = [CardSym] +type Deck = [CardSym] +type Discard = [CardSym] + +type GameLog = [GameMessage] +type GameMessage = Either GameLine GameError +type GameLine = String +type GameError = String + +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) +type Traits = [Trait] +data Mark = Circle | Triangle deriving (Show) +type LineMark = (Mark, Faction) +type LineMarks = [LineMark] + +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) + diff --git a/Util.hs b/Util.hs new file mode 100644 index 0000000..fbca5d6 --- /dev/null +++ b/Util.hs @@ -0,0 +1,23 @@ +module Util where + +rmFirstMatch :: [a] -> (a -> Bool) -> [a] +rmFirstMatch [] _ = [] +rmFirstMatch (l:ls) f + | f l = ls + | otherwise = (l : rmFirstMatch ls f) + +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" + +-- 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)) +