evac/State.hs

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 (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)
--}