icfp14/Eval.hs

{-# OPTIONS -XTypeSynonymInstances #-}

module Eval (
	Game (..),
	Player (..),
	Fields,
	Field,
	Turn (..),
	Value (..),
	Card (..),
	MonadIO (..),
	cardNames,
	pCard,
	Move (..),
	card,
	initGame,
	getGame,
	try,
	runMove,
	runTurn,
	testMoves,
	testMoves1
) where

import Control.Monad
import qualified Data.Array.IO as A
import System.IO
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 AIState = AIState deriving (Show, Eq)

data Game = Game { proponent, opponent :: Player, applications :: Int, automode :: Bool, gameturn :: Integer, aistate :: AIState } 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)

class Monad m => MonadIO m where
	liftIO :: IO x -> m x

instance MonadIO Turn where
	liftIO f = Turn $ \game -> f >>= \x -> return (game, Right x)

modifyGame :: (Game -> Game) -> Turn ()
modifyGame f = Turn $ \game -> return (f game, Right ())

getGame :: Turn Game
getGame = Turn $ \game -> return (game, Right game)

switchPlayer :: Turn ()
switchPlayer = modifyGame $ \game -> game { proponent = opponent game, opponent = proponent game, gameturn = 1 + gameturn game }

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 = modifyGame $ \game -> game {applications = 0}

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
	modifyGame $ \game -> game { automode = True }
	forM_ [0..255] $ \slot -> do
		(_, (val, vit)) <- readSlot proponent slot
		when (vit == -1) $ do
			try (reset >> tryApply val (card Card_I)) (\s -> liftIO $ hPutStrLn stderr $ "Error for zombie " ++ (show slot) ++ ": " ++ s)
			writeSlot proponent slot (card Card_I, 0)
	modifyGame $ \game -> game { automode = False }

runMove :: Move -> Turn ()
runMove m = do
		runauto
		try (do
				(l, r, field) <- getmove m
				reset
				try (tryApply l r >>= writeValue proponent field) (\s -> do
					writeValue proponent field (card Card_I)
					liftIO (hPutStrLn stderr $ "Error: " ++ s))
					) (\s -> liftIO (hPutStrLn stderr $ "Fatal Error in '" ++ show m ++ "': " ++ s))
		getGame >>= \game -> liftIO $ hPutStrLn stderr (show game)
		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
initAIState = return AIState
initGame :: IO Game
initGame = do
	p0 <- initPlayer
	p1 <- initPlayer
	ai <- initAIState
	return $ Game p0 p1 0 False 0 ai


runTurn :: Turn () -> Game -> IO Game
runTurn turn game = runTurn' turn game >>= \res -> case res of
	(game', Left s) -> (hPutStrLn stderr $ "Error in turn: " ++ s) >> return game
	(game', Right _) -> return game
runMoves :: [Move] -> Game -> IO Game
runMoves moves game = foldM (flip runTurn) game $ map runMove moves

testMoves :: [Move] -> IO Game
testMoves moves = initGame >>= runMoves moves

testMoves1 :: [Move] -> IO Game
testMoves1 moves = initGame >>= \game -> foldM (\g t -> runTurn (t >> switchPlayer) g) game $ map runMove moves