From 4a81233848e87d6c499e82ff2ba4be2495044e3b Mon Sep 17 00:00:00 2001 From: Shaun Kerr Date: Wed, 22 May 2019 13:06:18 +1200 Subject: [PATCH] finished refactor, compiles and runs as before now --- README.md | 35 ++++++++++++--------- src/Cogs/Groups.hs | 15 +++++---- src/Cogs/Players.hs | 2 +- src/ComBoard/{Print.hs => Printer.hs} | 8 ++--- src/Leads/ComBoard.hs | 15 +++++++-- src/Leads/Connect.hs | 57 ----------------------------------- src/Leads/Groups.hs | 36 ++++++++++++++++++---- src/Leads/Lines.hs | 11 +++++++ src/Toolbox/{Util.hs => Utils.hs} | 0 9 files changed, 85 insertions(+), 94 deletions(-) rename src/ComBoard/{Print.hs => Printer.hs} (90%) delete mode 100644 src/Leads/Connect.hs create mode 100644 src/Leads/Lines.hs rename src/Toolbox/{Util.hs => Utils.hs} (100%) diff --git a/README.md b/README.md index c9a533f..89720de 100644 --- a/README.md +++ b/README.md @@ -7,9 +7,9 @@ tA's Rules Engine for the Neon Genesis Evangelion Trading Card Game. Currently only runs in GHCI ```haskell -:load Connect.hs Print.hs Init.hs -import Print -import Init +:load Leads/Groups.hs ComBoard/Printer.hs ComBoard/Init.hs +import ComBoard.Printer +import ComBoard.Init ``` To print the representation of the initial board state @@ -17,32 +17,37 @@ To print the representation of the initial board state printState initBS ``` -`conHurt` and `conAttract` are currently the only implemented mechanics +`hurt` and `attract` are currently the only implemented main mechanics ```haskell -printState $ conHurt Asuka Gendo $ conAttract Shinji Asuka initBS +printState $ (attract Ritsuko Misato) + . (hurt Shinji Gendo) + . (attract Asuka Shinji) + . (hurt Rei Ritsuko) + $ initBS ``` returns: ```plaintext -== BOARD STATE == +== BOARD STATE == - Groups - -A ~ [ Shinji, Asuka ] <-> BCDE -B ~ [ Rei ] <-> AE -C ~ [ Misato ] <-> AD -D ~ [ Ritsuko ] <-> ACE -E ~ [ Gendo ] <-> ABD +A ~ [ Ritsuko, Misato ] <-> BD +B ~ [ Shinji, Asuka ] <-> ACD +C ~ [ Rei ] <-> BD +D ~ [ Gendo ] <-> ABC - Downed - ~ Gendo +~ Ritsuko - GameLog - -Shinji attracted Asuka, Asuka's group joined Shinji's group -Asuka hurt Gendo, Gendo is downed +Rei hurts Ritsuko, Ritsuko is downed! +Shinji attracts Asuka, both groups are joined +Shinji hurts Gendo, Gendo is downed! +Ritsuko attracts Misato, both groups are joined ================= ``` - ### Dependencies -`Data.List` and `Data.Either` +`Data.List` and `Maybe (Data.Either)` ## Authors diff --git a/src/Cogs/Groups.hs b/src/Cogs/Groups.hs index 0b87c48..1ed9bba 100644 --- a/src/Cogs/Groups.hs +++ b/src/Cogs/Groups.hs @@ -33,22 +33,22 @@ isDowned c bs = c `elem` d -- Return true if character is not grouped isAlone :: MainCharacter -> BoardState -> Bool -isAlone c bs = curFrens c g == [] +isAlone c bs = curFrens c bs == [] where g = (ntGroups . bsNeoTokyo) bs -- Return true if X is adjacent to Y isAdjacent :: MainCharacter -> MainCharacter -> BoardState -> Bool -isAdjacent x y bs = y `elem` (getAdj x g) +isAdjacent x y bs = y `elem` (getAdj x bs) where g = (ntGroups . bsNeoTokyo) bs -- All characters a X is adjacent to getAdj :: MainCharacter -> BoardState -> [MainCharacter] -getAdj x bs = curFrens x g ++ (foldr (++) [] (adjGroups x g)) +getAdj x bs = curFrens x bs ++ (foldr (++) [] (adjGroups x bs)) where g = (ntGroups . bsNeoTokyo) bs -- The characters currently grouped with x curFrens :: MainCharacter -> BoardState -> [MainCharacter] -curFrens x bs = filter (/= x) $ charsGroup x g +curFrens x bs = filter (/= x) $ charsGroup x bs where g = (ntGroups . bsNeoTokyo) bs -- The group that character x belongs to @@ -63,13 +63,12 @@ otherGroups x bs = filter (\y -> not $ x `elem` y) g -- The groups a character is adaject to adjGroups :: MainCharacter -> BoardState -> Groups -adjGroups x bs = filter (\y -> any (\z -> z `elem` adjFrens) y) (otherGroups x g) +adjGroups x bs = filter (\y -> any (\z -> z `elem` adjFrens) y) (otherGroups x bs) where - adjFrens = uniq $ foldr (++) [] (map defFrens $ charsGroup x g) + adjFrens = uniq $ foldr (++) [] (map defFrens $ charsGroup x bs) g = (ntGroups . bsNeoTokyo) bs -- The groups a group is adjacent to neighborGroups :: Group -> BoardState -> Groups -neighborGroups g bs = uniq . concat $ map (\x -> adjGroups x gs) g - where g = (ntGroups . bsNeoTokyo) bs +neighborGroups g bs = uniq . concat $ map (\x -> adjGroups x bs) g diff --git a/src/Cogs/Players.hs b/src/Cogs/Players.hs index cdc9667..a065bdb 100644 --- a/src/Cogs/Players.hs +++ b/src/Cogs/Players.hs @@ -6,7 +6,7 @@ module Cogs.Players where -- ==== import ComBoard.Types -import Util +import Toolbox.Utils -- Returns whether CardSym is in PlayerId's hand isInHand :: CardSym -> PlayerId -> BoardState -> Bool diff --git a/src/ComBoard/Print.hs b/src/ComBoard/Printer.hs similarity index 90% rename from src/ComBoard/Print.hs rename to src/ComBoard/Printer.hs index 26a60ab..27d9a53 100644 --- a/src/ComBoard/Print.hs +++ b/src/ComBoard/Printer.hs @@ -4,8 +4,8 @@ module ComBoard.Printer where -- Prints the state of the ComBoard -- ==== -import Types -import Groups +import ComBoard.Types +import Cogs.Groups import Data.List printState :: BoardState -> IO () @@ -16,7 +16,7 @@ printState bs = do map (\(gid, x) -> [gid] ++ " ~ [ " ++ concatGroup x ++ " ] <-> " ++ - (map fst $ filter (\(_,y) -> y `elem` (neighborGroups x groups)) zipGroups) + (map fst $ filter (\(_,y) -> y `elem` (neighborGroups x bs)) zipGroups) ) zipGroups putStrLn " - Downed -" mapM_ putStrLn $ map @@ -28,7 +28,7 @@ printState bs = do Left m -> m Right e -> " : " ++ e) (bsGameLog bs) - putStrLn " =================" + putStrLn "=================" where groups = (ntGroups . bsNeoTokyo) bs concatGroup x = concat $ intersperse ", " (map show x) diff --git a/src/Leads/ComBoard.hs b/src/Leads/ComBoard.hs index be4844b..6d62b41 100644 --- a/src/Leads/ComBoard.hs +++ b/src/Leads/ComBoard.hs @@ -11,7 +11,7 @@ import Cogs.Players -- Sets the groups in NeoTokyo setGroups :: Groups -> BoardState -> BoardState setGroups gs bs = bs - { bsNeoTokyo = (bsNeoTokyo bs) { nsGroups = gs } } + { bsNeoTokyo = (bsNeoTokyo bs) { ntGroups = gs } } -- Sets the downed in NeoTokyo setDowned :: Downed -> BoardState -> BoardState @@ -24,8 +24,17 @@ setPlayerLib pl bs = bs { bsPlayerLib = pl } -- Sets a players state setPlayer :: PlayerId -> PlayerState -> BoardState -> BoardState -setPlayer pi ps bs = setPlayerLib $ map - (\(pid,state) -> if (pid == pi) then ps else state) pl +setPlayer pi ps bs = setPlayerLib (map + (\(pid,state) -> if (pid == pi) then (pid,ps) else (pid,state)) pl) bs where pl = (bsPlayerLib bs) +-- Adds a message to the game log +addGameMessage :: String -> BoardState -> BoardState +addGameMessage m bs = bs + { bsGameLog = (bsGameLog bs) ++ [ Left m ] } + +-- Adds an error to the game log +addGameError :: String -> BoardState -> BoardState +addGameError e bs = bs + { bsGameLog = (bsGameLog bs) ++ [ Right e ] } diff --git a/src/Leads/Connect.hs b/src/Leads/Connect.hs deleted file mode 100644 index 23fa1e6..0000000 --- a/src/Leads/Connect.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Leads.Groups where - --- == Leads - Groups == --- Functions of type :: Arg1... -> BoardState -> BoardState --- Changes state of groups - -import ComBoard.Types -import Cogs.Groups - --- X hurts Y -conHurt :: MainCharacter -> MainCharacter -> BoardState -> BoardState -conHurt charX charY oldBoardState - | not $ isAdjacent charX charY oldGroups = oldBoardState - { bsGameLog = (bsGameLog oldBoardState) - ++ [ Right (show charX ++ " is not adjacent to " ++ show charY ++ ", could not hurt") ] - } - | isAlone charY oldGroups = oldBoardState - { bsGameLog = (bsGameLog oldBoardState) - ++ [ Left (show charX ++ " hurt " ++ show charY ++ ", " ++ show charY ++ " is downed") ] - , bsNeoTokyo = (bsNeoTokyo oldBoardState) - { ntPutCards = filter (\x -> ((fst x) /= Left charX)) oldPut - , ntDowned = downChar charY oldDowned - } - } - | otherwise = oldBoardState - { bsGameLog = (bsGameLog oldBoardState) - ++ [ Left (show charX ++ " hurt " ++ show charY ++ ", " ++ show charY ++ " left their group") ] - , bsNeoTokyo = (bsNeoTokyo oldBoardState) - { ntGroups = removeFromGroup charY oldGroups } - } - where - oldDowned = (ntDowned . bsNeoTokyo) oldBoardState - oldGroups = (ntGroups . bsNeoTokyo) oldBoardState - oldPut = (ntPutCards . bsNeoTokyo) oldBoardState - --- X attracts Y -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") ] - } - | isDowned charX oldDowned = 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/src/Leads/Groups.hs b/src/Leads/Groups.hs index afdffda..d1a4080 100644 --- a/src/Leads/Groups.hs +++ b/src/Leads/Groups.hs @@ -5,26 +5,28 @@ module Leads.Groups where -- Changes state of groups -- ==== +import Cogs.Groups import Leads.ComBoard import ComBoard.Types import Toolbox.Utils -- Return the groups with C removed from its current group removeFromGroup :: MainCharacter -> BoardState -> BoardState -removeFromGroup c bs = setGroups ( [c] : (groupMinusChar c) : (otherGroups c g) ) bs +removeFromGroup c bs = setGroups ( [c] : (groupMinusChar c) : (otherGroups c bs) ) bs where - groupMinusChar x = curFrens x g + groupMinusChar x = curFrens x bs g = (ntGroups . bsNeoTokyo) bs -- Return the groups with X grouped with Y joinGroups :: MainCharacter -> MainCharacter -> BoardState -> BoardState joinGroups x y bs - | x `elem` curFrens y g = bs - | otherwise = setGroups ((groupX ++ groupY) : (otherGroups x . otherGroups y) g) bs + | x `elem` curFrens y bs = bs + | otherwise = setGroups ((groupX ++ groupY) : ogs) bs where g = (ntGroups . bsNeoTokyo) bs - groupX = charsGroup x g - groupY = charsGroup y g + groupX = charsGroup x bs + groupY = charsGroup y bs + ogs = otherGroups y (setGroups (otherGroups x bs) bs) -- Return the Downed with the new character downChar :: MainCharacter -> BoardState -> BoardState @@ -39,3 +41,25 @@ readyChar :: MainCharacter -> BoardState -> BoardState readyChar c bs = setDowned (filter (/= c) d) bs where d = (ntDowned . bsNeoTokyo) bs + +-- Have character X attract Y +attract :: MainCharacter -> MainCharacter -> BoardState -> BoardState +attract charX charY bs + | charY `elem` d = (addGameMessage + (show charX ++ " attracts " ++ show charY ++ ", " ++ show charY ++ " is readied!")) + . (readyChar charY) $ bs + | otherwise = (addGameMessage + (show charX ++ " attracts " ++ show charY ++ ", both groups are joined")) + . (joinGroups charX charY) $ bs + where + d = (ntDowned . bsNeoTokyo) bs + +-- Have character X hurt Y +hurt :: MainCharacter -> MainCharacter -> BoardState -> BoardState +hurt charX charY bs + | isAlone charY bs = (addGameMessage + (show charX ++ " hurts " ++ show charY ++ ", " ++ show charY ++ " is downed!")) + . (downChar charY) {- . (removePut charY) -} $ bs + | otherwise = (addGameMessage + (show charX ++ " hurts " ++ show charY ++ ", " ++ show charY ++ " is seperated")) + . (removeFromGroup charY) $ bs diff --git a/src/Leads/Lines.hs b/src/Leads/Lines.hs new file mode 100644 index 0000000..2d2709a --- /dev/null +++ b/src/Leads/Lines.hs @@ -0,0 +1,11 @@ +module Leads.Lines where + +-- == Leads - Lines == +-- Functions of type :: Arg1... -> BoardState -> BoardState +-- used to change state of line cards +-- ==== + +import ComBoard.Types +import Toolbox.Utils + + diff --git a/src/Toolbox/Util.hs b/src/Toolbox/Utils.hs similarity index 100% rename from src/Toolbox/Util.hs rename to src/Toolbox/Utils.hs