icfp/icfp14
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

next

Browse Source
This commit is contained in:
Stefan Bühler 2011-06-18 20:23:56 +02:00
parent b5c52365b3
commit 6aab9b9c2e
7 changed files with 249 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
AI.hs Normal file
View File

@ -0,0 +1,10 @@
module AI (aimove) where
import Eval
import Lambda
import GoalTransform
aimove :: Turn Goal
aimove = return (Just 0, read "S dec (S get I)")

75
Client.hs Normal file
View File

@ -0,0 +1,75 @@
module Client where
import Eval
import Lambda
import AI
import GoalTransform
import System.IO
import System.Environment
import Control.Monad
import qualified Data.Array.IO as A
readMove :: Turn Move
readMove = do
lr <- liftIO getLine
sf <- liftIO getLine
st <- liftIO getLine
if (lr == "1") then (do
let f = read sf :: Card
let t = read st :: Int
return $ MoveLeft f t
) else (do
let f = read sf :: Int
let t = read st :: Card
return $ MoveRight f t
)
stepClient :: Turn ()
stepClient = readMove >>= runMove
stepAI :: Turn Goal -> Turn ()
stepAI ai = do
try (do
goal <- ai
move <- moveGoal goal
liftIO $ printMove move
runMove move
) (\s -> do
liftIO $ hPutStrLn stderr $ "Error calculating move"
game <- getGame
ownfields <- liftIO $ A.getAssocs (fields $ proponent game)
let (a, _):_ = filter (\(_, (_, v)) -> v > 0) ownfields
liftIO $ hPutStrLn stderr $ "=> I " ++ show a
liftIO $ printMove (MoveLeft Card_I a)
runMove (MoveLeft Card_I a)
)
run :: Turn Goal -> Bool -> IO ()
run ai firstPlayer = do
hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
game <- initGame
runTurn _loop1 game
return ()
where
_loop1 :: Turn ()
_loop1 = do
when (firstPlayer) (stepAI ai)
_loop
_loop :: Turn ()
_loop = do
stepClient
stepAI ai
_loop
getArgsFirstPlayer :: IO Bool
getArgsFirstPlayer = do
arg:_ <- getArgs
return $ arg == "0"
main = getArgsFirstPlayer >>= run aimove

77
Eval.hs
View File

@ -8,18 +8,23 @@ module Eval (
Turn (..), Turn (..),
Value (..), Value (..),
Card (..), Card (..),
MonadIO (..),
cardNames, cardNames,
pCard, pCard,
Move (..), Move (..),
card, card,
initGame, initGame,
run, getGame,
try,
runMove,
runTurn,
testMoves, testMoves,
testMoves1 testMoves1
) where ) where
import Control.Monad import Control.Monad
import qualified Data.Array.IO as A import qualified Data.Array.IO as A
import System.IO
import System.IO.Unsafe import System.IO.Unsafe
import Data.Maybe import Data.Maybe
@ -29,7 +34,10 @@ import Data.Char
type Field = (Value, Int) type Field = (Value, Int)
type Fields = A.IOArray Int Field type Fields = A.IOArray Int Field
data Player = Player { fields :: Fields } deriving (Show, Eq) data Player = Player { fields :: Fields } deriving (Show, Eq)
data Game = Game { proponent, opponent :: Player, applications :: Int, automode :: Bool, gameturn :: Integer } 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 Turn x = Turn { runTurn' :: Game -> IO (Game, Either String x) }
@ -57,11 +65,20 @@ class Monad m => MonadIO m where
instance MonadIO Turn where instance MonadIO Turn where
liftIO f = Turn $ \game -> f >>= \x -> return (game, Right x) 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 :: 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 ()) 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 ()
reset = Turn $ \game -> return (game {applications = 0}, Right ()) reset = modifyGame $ \game -> game {applications = 0}
try :: Turn x -> (String -> Turn y) -> Turn () 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)) 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))
@ -148,18 +165,18 @@ reviveSlot player slot = do
card :: Card -> Value card :: Card -> Value
card Card_I = take1 "I" $ return card Card_I = take1 "I" $ return
card Card_Zero = ValInt 0 card Card_Zero = ValInt 0
card Card_Succ = take1 "Succ" $ getInt >=> return . int . (+1) card Card_Succ = take1 "succ" $ getInt >=> return . int . (+1)
card Card_Dbl = take1 "Dbl" $ getInt >=> return . int . (*2) card Card_Dbl = take1 "dbl" $ getInt >=> return . int . (*2)
card Card_Get = take1 "Get" $ getAliveSlot proponent >=> \(_, (val, _)) -> return val card Card_Get = take1 "get" $ getAliveSlot proponent >=> \(_, (val, _)) -> return val
card Card_Put = take1 "Put" $ const $ return $ card Card_I card Card_Put = take1 "put" $ const $ return $ card Card_I
card Card_S = take3 "S" $ \f g x -> do card Card_S = take3 "S" $ \f g x -> do
h <- tryApply f x h <- tryApply f x
y <- tryApply g x y <- tryApply g x
tryApply h y tryApply h y
card Card_K = take2 "K" $ \x _ -> return x 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_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_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 card Card_Attack = take3 "attack" $ \i j n -> do
i <- getSlotNo i i <- getSlotNo i
n <- getInt n n <- getInt n
autoSwitch (do autoSwitch (do
@ -175,7 +192,7 @@ card Card_Attack = take3 "Attack" $ \i j n -> do
j <- getSlotNo j j <- getSlotNo j
healSlot opponent ((n*9) `div` 10) (255-j) healSlot opponent ((n*9) `div` 10) (255-j)
) )
card Card_Help = take3 "Help" $ \i j n -> do card Card_Help = take3 "help" $ \i j n -> do
i <- getSlotNo i i <- getSlotNo i
n <- getInt n n <- getInt n
autoSwitch (do autoSwitch (do
@ -191,9 +208,9 @@ card Card_Help = take3 "Help" $ \i j n -> do
j <- getSlotNo j j <- getSlotNo j
pierceSlot proponent ((n*11) `div` 10) (255-j) pierceSlot proponent ((n*11) `div` 10) (255-j)
) )
card Card_Copy = take1 "Copy" $ getSlotNo >=> readSlot opponent >=> \(_, (val, _)) -> return val 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_Revive = take1 "revive" $ getSlotNo >=> reviveSlot proponent >=> const (return $ card Card_I)
card Card_Zombie = take2 "Zombie" $ \i x -> do card Card_Zombie = take2 "zombie" $ \i x -> do
i <- getSlotNo i i <- getSlotNo i
(_, (_, vit)) <- readSlot opponent (255-i) (_, (_, vit)) <- readSlot opponent (255-i)
when (vit > 0) $ fail "Zombie: slot is still alive" when (vit > 0) $ fail "Zombie: slot is still alive"
@ -202,23 +219,25 @@ card Card_Zombie = take2 "Zombie" $ \i x -> do
runauto :: Turn () runauto :: Turn ()
runauto = do runauto = do
Turn $ \game -> return (game { automode = True }, Right ()) modifyGame $ \game -> game { automode = True }
forM_ [0..255] $ \slot -> do forM_ [0..255] $ \slot -> do
(_, (val, vit)) <- readSlot proponent slot (_, (val, vit)) <- readSlot proponent slot
when (vit == -1) $ do when (vit == -1) $ do
try (reset >> tryApply val (card Card_I)) (\s -> liftIO $ putStrLn $ "Error for zombie " ++ (show slot) ++ ": " ++ s) try (reset >> tryApply val (card Card_I)) (\s -> liftIO $ hPutStrLn stderr $ "Error for zombie " ++ (show slot) ++ ": " ++ s)
writeSlot proponent slot (card Card_I, 0) writeSlot proponent slot (card Card_I, 0)
Turn $ \game -> return (game { automode = False }, Right ()) modifyGame $ \game -> game { automode = False }
switchPlayer :: Turn ()
switchPlayer = Turn $ \game -> return (game { proponent = opponent game, opponent = proponent game, gameturn = 1 + gameturn game }, Right ())
runMove :: Move -> Turn () runMove :: Move -> Turn ()
runMove m = do runMove m = do
(l, r, field) <- getmove m
runauto runauto
try (reset >> tryApply l r >>= writeValue proponent field) (\s -> writeValue proponent field (card Card_I) >> liftIO (putStrLn $ "Error: " ++ s)) try (do
Turn $ \game -> putStrLn (show game) >> return (game, Right ()) (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 switchPlayer
where where
getmove :: Move -> Turn (Value, Value, Int) getmove :: Move -> Turn (Value, Value, Int)
@ -234,22 +253,24 @@ initFields :: IO Fields
initFields = A.newArray (0, 255) (card Card_I, 10000) initFields = A.newArray (0, 255) (card Card_I, 10000)
initPlayer :: IO Player initPlayer :: IO Player
initPlayer = initFields >>= return . Player initPlayer = initFields >>= return . Player
initAIState = return AIState
initGame :: IO Game initGame :: IO Game
initGame = do initGame = do
p0 <- initPlayer p0 <- initPlayer
p1 <- initPlayer p1 <- initPlayer
return $ Game p0 p1 0 False 0 ai <- initAIState
return $ Game p0 p1 0 False 0 ai
runTurn :: Turn () -> Game -> IO Game runTurn :: Turn () -> Game -> IO Game
runTurn turn game = runTurn' turn game >>= \res -> case res of runTurn turn game = runTurn' turn game >>= \res -> case res of
(game', Left s) -> (putStrLn $ "Error in turn: " ++ s) >> return game (game', Left s) -> (hPutStrLn stderr $ "Error in turn: " ++ s) >> return game
(game', Right _) -> return game (game', Right _) -> return game
run :: [Move] -> Game -> IO Game runMoves :: [Move] -> Game -> IO Game
run moves game = foldM (flip runTurn) game $ map runMove moves runMoves moves game = foldM (flip runTurn) game $ map runMove moves
testMoves :: [Move] -> IO Game testMoves :: [Move] -> IO Game
testMoves moves = initGame >>= run moves testMoves moves = initGame >>= runMoves moves
testMoves1 :: [Move] -> IO Game testMoves1 :: [Move] -> IO Game
testMoves1 moves = initGame >>= \game -> foldM (\g t -> runTurn (t >> switchPlayer) g) game $ map runMove moves testMoves1 moves = initGame >>= \game -> foldM (\g t -> runTurn (t >> switchPlayer) g) game $ map runMove moves

87
GoalTransform.hs Normal file
View File

@ -0,0 +1,87 @@
module GoalTransform (
Goal (..),
moveGoal,
evalMoves,
subgoals,
) where
import Eval
import Lambda
import System.IO
import qualified Data.Array.IO as A
type Goal = (Maybe Int, Term)
type Goals = [(Int, Term)]
applyMove :: Term -> Move -> Term
applyMove t (MoveLeft Card_Zero _) = Prim Card_I
applyMove t (MoveLeft Card_I _) = t
applyMove (Const n) (MoveLeft Card_Succ _) = Const (n+1)
applyMove (Const n) (MoveLeft Card_Dbl _) = Const (n*2)
applyMove (Prim Card_I) (MoveRight _ Card_Zero) = Const 0
applyMove (Prim Card_I) (MoveRight _ c) = Prim c
applyMove (Prim Card_Succ) (MoveRight _ Card_Zero) = Const 1
applyMove (Prim Card_Dbl) (MoveRight _ Card_Zero) = Const 0
applyMove t (MoveLeft c _) = Apply (Prim c) t
applyMove t (MoveRight _ c) = Apply t (Prim c)
evalMoves :: Goals -> Int -> Maybe Term -> [Move] -> [(Goals, Move)]
evalMoves current pos = _eval where
_eval _ [] = []
_eval Nothing moves = ((pos, Prim Card_I):current, MoveLeft Card_Zero pos):_eval (Just $ Prim Card_I) moves
_eval (Just t) (m:xm) = let t' = (applyMove t m) in ((pos, t'):current, m):_eval (Just t') xm
copyTo :: Goals -> Int -> Int -> [(Goals, Move)]
copyTo current src dst = if (src == dst) then [] else evalMoves current dst Nothing (storeInt dst src ++ [MoveLeft Card_Get dst])
_subgoals current pos (Const n) = evalMoves current pos Nothing (storeInt pos n)
_subgoals current pos (Apply (Prim c) t) = let m = MoveLeft c pos in _subgoals current pos t ++ [((pos, applyMove t m):current, m)]
_subgoals current pos (Apply (Const 0) t) = let m = MoveLeft Card_Zero pos in _subgoals current pos t ++ [((pos, applyMove t m):current, m)]
_subgoals current pos (Apply t (Prim c)) = let m = MoveRight pos c in _subgoals current pos t ++ [((pos, applyMove t m):current, m)]
_subgoals current pos (Apply t (Const 0)) = let m = MoveRight pos Card_Zero in _subgoals current pos t ++ [((pos, applyMove t m):current, m)]
_subgoals current pos (Prim c) = evalMoves current pos Nothing [MoveRight pos c]
_subgoals current 0 (Apply a b) = _subgoals current 1 (Apply a b) ++ copyTo ((1, Apply a b):current) 1 0
_subgoals current pos (Apply a b) = _subgoals current pos a ++ _subgoals ((pos,a):current) (pos+1) b ++ copyTo ((pos,a):(pos+1, b):current) (pos+1) 0 ++ evalMoves ((0, b):current) pos (Just a) [MoveLeft Card_K pos, MoveLeft Card_S pos, MoveRight pos Card_Get, MoveRight pos Card_Zero]
subgoals pos t = reverse $ _subgoals [] pos t
termEqVal :: Term -> Value -> Bool
termEqVal (Const a) (ValInt b) = (a == b)
termEqVal (Prim Card_Zero) (ValInt 0) = True
termEqVal t (ValFunction s _) = (show t) == s
termEqVal _ _ = False
satGoal :: (Int, Term) -> Turn Bool
satGoal (pos, t) = do
game <- getGame
(val, vit) <- liftIO $ A.readArray (fields $ proponent game) pos
return (vit > 0 && termEqVal t val)
satGoals :: Goals -> Turn Bool
satGoals [] = return True
satGoals (g:xg) = satGoal g >>= \r -> if (r) then satGoals xg else return False
_pickMove :: [(Goals, Move)] -> Turn (Maybe Move)
_pickMove [] = return Nothing
_pickMove ((g,m):xs) = do
found <- satGoals g
if (found) then return Nothing else do
r <- _pickMove xs
case r of Nothing -> return $ Just m; _ -> return r
pickMove :: [(Goals, Move)] -> Turn (Move, Bool)
pickMove l@((_,m):_) = do
r <- _pickMove l
case r of Nothing -> return (m, True); Just m -> return (m, False)
moveGoal :: Goal -> Turn Move
moveGoal (Nothing, t) = moveGoal (Just 0, t)
moveGoal (Just pos, t) = do
let subs = subgoals pos t
(move, finished) <- pickMove subs
liftIO $ hPutStrLn stderr $ "Trying to reach Goal " ++ show (pos, t)
liftIO $ hPutStrLn stderr $ "Next step: " ++ show move
return move

14
Lambda.hs
View File

@ -1,17 +1,21 @@
{-# OPTIONS -XTypeSynonymInstances #-} {-# OPTIONS -XTypeSynonymInstances #-}
module Lambda where module Lambda (
Term (..),
store, storeInt,
command, callresult, loop,
printMove
) where
import Eval import Eval
import System.IO
import System.IO
import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadP
import Data.Char import Data.Char
import Control.Monad import Control.Monad
data Term = Const Int | Prim Card | Seq Term Term | Apply Term Term data Term = Const Int | Prim Card | Seq Term Term | Apply Term Term
ptConst :: ReadP Term ptConst :: ReadP Term
ptConst = readS_to_P reads >>= return . Const ptConst = readS_to_P reads >>= return . Const
ptPrim = do ptPrim = do
@ -38,8 +42,8 @@ instance Show Term where
show (Const i) = show i show (Const i) = show i
show (Prim c) = show c show (Prim c) = show c
show (Seq f g) = show f ++ ";" ++ show g show (Seq f g) = show f ++ ";" ++ show g
show (Apply f (Const i)) = show f ++ " " ++ show i {- show (Apply f (Const i)) = show f ++ " " ++ show i
show (Apply f (Prim c)) = show f ++ " " ++ show c show (Apply f (Prim c)) = show f ++ " " ++ show c-}
show (Apply f x) = show f ++ "(" ++ show x ++ ")" show (Apply f x) = show f ++ "(" ++ show x ++ ")"
instance Read Term where instance Read Term where

18
dummy Executable file
View File

@ -0,0 +1,18 @@
#!/bin/sh
opp() {
read lr
case $lr in
1) read card; read slot;;
2) read slot; read card;;
esac
}
if [ $1 = "1" ]; then
opp
fi
while [ true ]; do
echo "1"
echo "I"
echo "0"
opp
done

2
run
View File

@ -1,4 +1,4 @@
#!/bin/sh #!/bin/sh
cd $(dirname $(readlink -f $0)) cd $(dirname $(readlink -f $0))
exec runghc Lambda.hs exec runghc Client.hs "$@"