You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
252 lines
9.9 KiB
252 lines
9.9 KiB
{-# OPTIONS -XTypeSynonymInstances #-} |
|
|
|
module Eval ( |
|
Game (..), |
|
Player (..), |
|
Fields, |
|
Field, |
|
Turn (..), |
|
Value (..), |
|
Card (..), |
|
cardNames, |
|
pCard, |
|
Move (..), |
|
card, |
|
initGame, |
|
run, |
|
testMoves, |
|
testMoves1 |
|
) where |
|
|
|
import Control.Monad |
|
import qualified Data.Array.IO as A |
|
import System.IO.Unsafe |
|
import Data.Maybe |
|
|
|
import Text.ParserCombinators.ReadP |
|
import Data.Char |
|
|
|
type Field = (Value, Int) |
|
type Fields = A.IOArray Int Field |
|
data Player = Player { fields :: Fields } deriving (Show, Eq) |
|
data Game = Game { proponent, opponent :: Player, applications :: Int, automode :: Bool, gameturn :: Integer } deriving (Show, Eq) |
|
|
|
data Turn x = Turn { runTurn' :: Game -> IO (Game, Either String x) } |
|
|
|
data Value = ValInt !Int | ValFunction String (Value -> Turn Value) |
|
vitality :: Int -> Int |
|
vitality x = if (x < 0) then 0 else if (x > 65535) then 65535 else x |
|
int :: Int -> Value |
|
int x = ValInt $ vitality x |
|
|
|
|
|
data Card = Card_I | Card_Zero | Card_Succ | Card_Dbl | Card_Get | Card_Put | Card_S | Card_K | Card_Inc | Card_Dec | Card_Attack | Card_Help | Card_Copy | Card_Revive | Card_Zombie deriving (Enum, Eq) |
|
data Move = MoveLeft Card Int | MoveRight Int Card |
|
|
|
cardNames = [(Card_I, "I"),(Card_Zero, "zero"),( Card_Succ, "succ"),( Card_Dbl, "dbl"),( Card_Get, "get"),( Card_Put, "put"),( Card_S, "S"),( Card_K, "K"),( Card_Inc, "inc"),( Card_Dec, "dec"),( Card_Attack, "attack"),( Card_Help, "help"),( Card_Copy, "copy"),( Card_Revive, "revive"),( Card_Zombie, "zombie")] |
|
cardNamesX = map (\(a,b) -> (b,a)) cardNames |
|
|
|
instance Monad Turn where |
|
(Turn f) >>= g = Turn $ \game -> (f game >>=) $ \(game', r) -> case r of Right x -> (case g x of Turn g' -> g' game'); Left s -> return (game', Left s) |
|
return x = Turn $ \game -> return (game, Right x) |
|
fail s = Turn $ \game -> return (game, Left s) |
|
|
|
liftIO :: IO x -> Turn x |
|
liftIO f = Turn $ \game -> f >>= \x -> return (game, Right x) |
|
|
|
apply :: Int -> Turn () |
|
apply n = Turn $ \game -> let a = n + (applications game) in let g = game { applications = a } in if a > 1000 then return (g, Left "Application limit exceeded") else return (g, Right ()) |
|
|
|
reset :: Turn () |
|
reset = Turn $ \game -> return (game {applications = 0}, Right ()) |
|
|
|
try :: Turn x -> (String -> Turn y) -> Turn () |
|
try (Turn action) catch = Turn $ \game -> (action game >>=) $ \(game', r) -> case r of Right _ -> return (game', Right ()); Left s -> case catch s of Turn catch' -> catch' game' >>= (\(game'', r) -> case r of Right _ -> return (game'', Right ()); Left s -> return (game'', Left s)) |
|
|
|
instance Show Value where |
|
show (ValInt i) = show i |
|
show (ValFunction name _) = name |
|
|
|
instance Show Fields where |
|
show f = unsafePerformIO $ do |
|
assocs <- A.getAssocs f |
|
return $ show $ filter (\(_, (val, vit)) -> vit /= 10000 || (show val /= "I")) assocs |
|
|
|
instance Show Card where |
|
show c = fromJust $ lookup c cardNames |
|
|
|
instance Show Move where |
|
show (MoveLeft c pos) = (show c) ++ " " ++ (show pos) |
|
show (MoveRight pos c) = (show pos) ++ " " ++ (show c) |
|
|
|
pCard :: ReadP Card |
|
pCard = do |
|
s <- many1 (satisfy isAlpha) |
|
case lookup s cardNamesX of |
|
Just c -> return c |
|
Nothing -> pfail |
|
pmPos = readS_to_P reads >>= \i -> if (i >= 0 && i <= 255) then return i else pfail |
|
|
|
pMove = skipSpaces >> ((do c <- pCard; skipSpaces; pos <- pmPos; skipSpaces; return $ MoveLeft c pos) <++ (do pos <- pmPos; skipSpaces; c <- pCard; skipSpaces; return $ MoveRight pos c)) |
|
|
|
instance Read Card where |
|
readsPrec _ = readP_to_S pCard |
|
instance Read Move where |
|
readsPrec _ = readP_to_S pMove |
|
|
|
|
|
take1 :: String -> (Value -> Turn Value) -> Value |
|
take1 name f = ValFunction name $ \v -> apply 1 >> f v |
|
take2 :: String -> (Value -> Value -> Turn Value) -> Value |
|
take2 name f = ValFunction name $ \v -> apply 1 >> return (take1 (name ++ "(" ++ show v ++ ")") (f v)) |
|
take3 :: String -> (Value -> Value -> Value -> Turn Value) -> Value |
|
take3 name f = ValFunction name $ \v -> apply 1 >> return (take2 (name ++ "(" ++ show v ++ ")") (f v)) |
|
|
|
getInt :: Value -> Turn Int |
|
getInt v = case v of ValInt x -> return x; _ -> fail "Expected Integer, got Function" |
|
getSlotNo :: Value -> Turn Int |
|
getSlotNo = getInt >=> \slot -> if (slot >= 0 && slot <= 255) then return slot else fail ("Invalid slot index " ++ (show slot)) |
|
getFunc :: Value -> Turn (Value -> Turn Value) |
|
getFunc v = case v of ValFunction _ x -> return x; _ -> fail "Expected Function, got Integer" |
|
tryApply :: Value -> Value -> Turn Value |
|
tryApply f v = case f of ValFunction _ f' -> f' v; _ -> fail "Expected Function, got Integer" |
|
|
|
readSlot :: (Game -> Player) -> Int -> Turn (Int, Field) |
|
readSlot player n = Turn $ \game -> A.readArray (fields $ player game) n >>= \field -> return (game, Right (n, field)) |
|
writeSlot :: (Game -> Player) -> Int -> Field -> Turn () |
|
writeSlot player n field = Turn $ \game -> A.writeArray (fields $ player game) n field >> return (game, Right ()) |
|
writeValue :: (Game -> Player) -> Int -> Value -> Turn () |
|
writeValue player n val = readSlot player n >>= \(_, (_, vit)) -> writeSlot player n (val, vit) |
|
|
|
getSlot :: (Game -> Player) -> Value -> Turn (Int, Field) |
|
getSlot player = getSlotNo >=> readSlot player |
|
|
|
getAliveSlot :: (Game -> Player) -> Value -> Turn (Int, Field) |
|
getAliveSlot player = getSlot player >=> \r@(slot, (_, vit)) -> if (vit > 0) then return r else fail ("Slot " ++ (show slot) ++ " not alive") |
|
|
|
autoSwitch :: Turn () -> Turn () -> Turn Value |
|
autoSwitch (Turn norm) (Turn aut) = (Turn $ \game -> if (automode game) then aut game else norm game) >> return (card Card_I) |
|
|
|
healSlot :: (Game -> Player) -> Int -> Int -> Turn () |
|
healSlot player amount slot = do |
|
(_, (val, vit)) <- readSlot player slot |
|
when (vit > 0) (writeSlot player slot (val, vitality $ vit + amount)) |
|
|
|
pierceSlot :: (Game -> Player) -> Int -> Int -> Turn () |
|
pierceSlot player amount slot = do |
|
(_, (val, vit)) <- readSlot player slot |
|
when (vit > 0) (writeSlot player slot (val, vitality $ vit - amount)) |
|
|
|
reviveSlot :: (Game -> Player) -> Int -> Turn () |
|
reviveSlot player slot = do |
|
(_, (val, vit)) <- readSlot player slot |
|
when (vit <= 0) (writeSlot player slot (val, 1)) |
|
|
|
card :: Card -> Value |
|
card Card_I = take1 "I" $ return |
|
card Card_Zero = ValInt 0 |
|
card Card_Succ = take1 "Succ" $ getInt >=> return . int . (+1) |
|
card Card_Dbl = take1 "Dbl" $ getInt >=> return . int . (*2) |
|
card Card_Get = take1 "Get" $ getAliveSlot proponent >=> \(_, (val, _)) -> return val |
|
card Card_Put = take1 "Put" $ const $ return $ card Card_I |
|
card Card_S = take3 "S" $ \f g x -> do |
|
h <- tryApply f x |
|
y <- tryApply g x |
|
tryApply h y |
|
card Card_K = take2 "K" $ \x _ -> return x |
|
card Card_Inc = take1 "Inc" $ getSlotNo >=> \slot -> autoSwitch (healSlot proponent 1 slot) (pierceSlot proponent 1 slot) |
|
card Card_Dec = take1 "Dec" $ getSlotNo >=> \slot -> autoSwitch (pierceSlot opponent 1 (255-slot)) (healSlot opponent 1 (255-slot)) |
|
card Card_Attack = take3 "Attack" $ \i j n -> do |
|
i <- getSlotNo i |
|
n <- getInt n |
|
autoSwitch (do |
|
(_, (_, vit)) <- readSlot proponent i |
|
when (vit < n) $ fail "Attack: not enough vitality" |
|
pierceSlot proponent n i |
|
j <- getSlotNo j |
|
pierceSlot opponent ((n*9) `div` 10) (255-j) |
|
) (do |
|
(_, (_, vit)) <- readSlot proponent i |
|
when (vit < n) $ fail "Attack: not enough vitality" |
|
pierceSlot proponent n i |
|
j <- getSlotNo j |
|
healSlot opponent ((n*9) `div` 10) (255-j) |
|
) |
|
card Card_Help = take3 "Help" $ \i j n -> do |
|
i <- getSlotNo i |
|
n <- getInt n |
|
autoSwitch (do |
|
(_, (_, vit)) <- readSlot proponent i |
|
when (vit < n) $ fail "Help: not enough vitality" |
|
pierceSlot proponent n i |
|
j <- getSlotNo j |
|
healSlot proponent ((n*11) `div` 10) (255-j) |
|
) (do |
|
(_, (_, vit)) <- readSlot proponent i |
|
when (vit < n) $ fail "Help: not enough vitality" |
|
pierceSlot proponent n i |
|
j <- getSlotNo j |
|
pierceSlot proponent ((n*11) `div` 10) (255-j) |
|
) |
|
card Card_Copy = take1 "Copy" $ getSlotNo >=> readSlot opponent >=> \(_, (val, _)) -> return val |
|
card Card_Revive = take1 "Revive" $ getSlotNo >=> reviveSlot proponent >=> const (return $ card Card_I) |
|
card Card_Zombie = take2 "Zombie" $ \i x -> do |
|
i <- getSlotNo i |
|
(_, (_, vit)) <- readSlot opponent (255-i) |
|
when (vit > 0) $ fail "Zombie: slot is still alive" |
|
writeSlot opponent (255-i) (x, -1) |
|
return $ card Card_I |
|
|
|
runauto :: Turn () |
|
runauto = do |
|
Turn $ \game -> return (game { automode = True }, Right ()) |
|
forM_ [0..255] $ \slot -> do |
|
(_, (val, vit)) <- readSlot proponent slot |
|
when (vit == -1) $ do |
|
try (reset >> tryApply val (card Card_I)) (\s -> liftIO $ putStrLn $ "Error for zombie " ++ (show slot) ++ ": " ++ s) |
|
writeSlot proponent slot (card Card_I, 0) |
|
Turn $ \game -> return (game { automode = False }, Right ()) |
|
|
|
switchPlayer :: Turn () |
|
switchPlayer = Turn $ \game -> return (game { proponent = opponent game, opponent = proponent game, gameturn = 1 + gameturn game }, Right ()) |
|
|
|
runMove :: Move -> Turn () |
|
runMove m = do |
|
(l, r, field) <- getmove m |
|
runauto |
|
try (reset >> tryApply l r >>= writeValue proponent field) (\s -> writeValue proponent field (card Card_I) >> liftIO (putStrLn $ "Error: " ++ s)) |
|
Turn $ \game -> putStrLn (show game) >> return (game, Right ()) |
|
switchPlayer |
|
where |
|
getmove :: Move -> Turn (Value, Value, Int) |
|
getmove (MoveLeft crd field) = do |
|
(_, (f, _)) <- getAliveSlot proponent (ValInt field) |
|
return (card crd, f, field) |
|
getmove (MoveRight field crd) = do |
|
(_, (f, _)) <- getAliveSlot proponent (ValInt field) |
|
return (f, card crd, field) |
|
|
|
|
|
initFields :: IO Fields |
|
initFields = A.newArray (0, 255) (card Card_I, 10000) |
|
initPlayer :: IO Player |
|
initPlayer = initFields >>= return . Player |
|
initGame :: IO Game |
|
initGame = do |
|
p0 <- initPlayer |
|
p1 <- initPlayer |
|
return $ Game p0 p1 0 False 0 |
|
|
|
|
|
runTurn :: Turn () -> Game -> IO Game |
|
runTurn turn game = runTurn' turn game >>= \res -> case res of |
|
(game', Left s) -> (putStrLn $ "Error in turn: " ++ s) >> return game |
|
(game', Right _) -> return game |
|
run :: [Move] -> Game -> IO Game |
|
run moves game = foldM (flip runTurn) game $ map runMove moves |
|
|
|
testMoves :: [Move] -> IO Game |
|
testMoves moves = initGame >>= run moves |
|
|
|
testMoves1 :: [Move] -> IO Game |
|
testMoves1 moves = initGame >>= \game -> foldM (\g t -> runTurn (t >> switchPlayer) g) game $ map runMove moves
|
|
|