Browse Source

next

master
Stefan Bühler 10 years ago
parent
commit
6aab9b9c2e
  1. 10
      AI.hs
  2. 75
      Client.hs
  3. 77
      Eval.hs
  4. 87
      GoalTransform.hs
  5. 14
      Lambda.hs
  6. 18
      dummy
  7. 2
      run

10
AI.hs

@ -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

@ -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

@ -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

@ -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

@ -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

@ -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

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