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 (..),
Value (..),
Card (..),
MonadIO (..),
cardNames,
pCard,
Move (..),
card,
initGame,
run,
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
@ -29,7 +34,10 @@ 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 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) }
@ -57,11 +65,20 @@ class Monad m => MonadIO m where
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 = Turn $ \game -> return (game {applications = 0}, Right ())
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))
@ -148,18 +165,18 @@ reviveSlot player slot = do
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_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
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
@ -175,7 +192,7 @@ card Card_Attack = take3 "Attack" $ \i j n -> do
j <- getSlotNo 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
n <- getInt n
autoSwitch (do
@ -191,9 +208,9 @@ card Card_Help = take3 "Help" $ \i j n -> do
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
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"
@ -202,23 +219,25 @@ card Card_Zombie = take2 "Zombie" $ \i x -> do
runauto :: Turn ()
runauto = do
Turn $ \game -> return (game { automode = True }, Right ())
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 $ 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)
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 ())
modifyGame $ \game -> game { automode = False }
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 ())
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)
@ -234,22 +253,24 @@ 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
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 = 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
run :: [Move] -> Game -> IO Game
run moves game = foldM (flip runTurn) game $ map runMove moves
runMoves :: [Move] -> Game -> IO Game
runMoves moves game = foldM (flip runTurn) game $ map runMove moves
testMoves :: [Move] -> IO Game
testMoves moves = initGame >>= run moves
testMoves moves = initGame >>= runMoves moves
testMoves1 :: [Move] -> IO Game
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 #-}
module Lambda where
module Lambda (
Term (..),
store, storeInt,
command, callresult, loop,
printMove
) where
import Eval
import System.IO
import System.IO
import Text.ParserCombinators.ReadP
import Data.Char
import Control.Monad
data Term = Const Int | Prim Card | Seq Term Term | Apply Term Term
ptConst :: ReadP Term
ptConst = readS_to_P reads >>= return . Const
ptPrim = do
@ -38,8 +42,8 @@ instance Show Term where
show (Const i) = show i
show (Prim c) = show c
show (Seq f g) = show f ++ ";" ++ show g
show (Apply f (Const i)) = show f ++ " " ++ show i
show (Apply f (Prim c)) = show f ++ " " ++ show c
{- show (Apply f (Const i)) = show f ++ " " ++ show i
show (Apply f (Prim c)) = show f ++ " " ++ show c-}
show (Apply f x) = show f ++ "(" ++ show x ++ ")"
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
cd $(dirname $(readlink -f $0))
exec runghc Lambda.hs
exec runghc Client.hs "$@"