From bb6957abc058047c0088127e3de213e09929f93d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Stefan=20B=C3=BChler?= Date: Fri, 17 Jun 2011 16:31:44 +0200 Subject: [PATCH] first eval commit --- Eval.hs | 220 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 220 insertions(+) create mode 100644 Eval.hs diff --git a/Eval.hs b/Eval.hs new file mode 100644 index 0000000..d5e5ad4 --- /dev/null +++ b/Eval.hs @@ -0,0 +1,220 @@ + +module Eval where + +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.Array.IO as A +import System.IO.Unsafe + +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 +data Move = MoveLeft Card Int | MoveRight Int Card + +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) + +instance MonadIO Turn where + 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 + +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 -> liftIO $ putStrLn $ "Error: " ++ s) + 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 + + + + + + + + + + + + + + +