This commit is contained in:
Stefan Bühler 2011-06-18 11:57:31 +02:00
parent bb6957abc0
commit 9e220ea366
3 changed files with 93 additions and 23 deletions

57
Eval.hs
View File

@ -1,10 +1,26 @@
{-# OPTIONS -XTypeSynonymInstances #-}
module Eval where
module Eval (
Game (..),
Player (..),
Fields,
Field,
Turn (..),
Value (..),
Card (..),
cardNames,
Move (..),
card,
initGame,
run,
testMoves,
testMoves1
) where
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Array.IO as A
import System.IO.Unsafe
import Data.Maybe
type Field = (Value, Int)
type Fields = A.IOArray Int Field
@ -20,16 +36,18 @@ 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 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")]
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)
liftIO :: IO x -> Turn x
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 ())
@ -49,12 +67,19 @@ instance Show Fields where
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)
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))
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))
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"
@ -168,7 +193,8 @@ 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)
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 ())
switchPlayer
where
getmove :: Move -> Turn (Value, Value, Int)
@ -203,18 +229,3 @@ testMoves moves = initGame >>= run moves
testMoves1 :: [Move] -> IO Game
testMoves1 moves = initGame >>= \game -> foldM (\g t -> runTurn (t >> switchPlayer) g) game $ map runMove moves

55
Lambda.hs Normal file
View File

@ -0,0 +1,55 @@
module Lambda where
import Eval
import System.IO
data Term = Const Int | Prim Card | Seq Term Term | Apply Term Term
cI = Prim Card_I
cGet n = Apply (Prim Card_Get) (Const n)
cPut = Prim Card_Put
cS [f, g] = Apply (Apply (Prim Card_S) f) g
cS [f, g, x] = Apply (Apply (Apply (Prim Card_S) f) g) x
cK x = Apply (Prim Card_K) x
cInc i = Apply (Prim Card_Inc) (Const i)
cDec i = Apply (Prim Card_Dec) (Const i)
cAttack [i, j] = Apply (Apply (Prim Card_Attack) (Const i)) (Const j)
cAttack [i, j, n] = Apply (Apply (Apply (Prim Card_Attack) (Const i)) (Const j)) (Const n)
cHelp [i, j] = Apply (Apply (Prim Card_Help) (Const i)) (Const j)
cHelp [i, j, n] = Apply (Apply (Apply (Prim Card_Help) (Const i)) (Const j)) (Const n)
cCopy i = Apply (Prim Card_Copy) (Const i)
cRevive i = Apply (Prim Card_Revive) (Const i)
cZombie i x = Apply (Apply (Prim Card_Zombie) (Const i)) x
test1 = cAttack [9, 8, 4000]
storeInt :: Int -> Int -> [Move]
storeInt pos = _store where
_store :: Int -> [Move]
_store 0 = [MoveLeft Card_Zero pos, MoveRight pos Card_Zero]
_store n = if (n `mod` 2 == 0) then _store (n `div` 2) ++ [MoveLeft Card_Dbl pos] else _store (n-1) ++ [MoveLeft Card_Succ pos]
command (Apply f x) = Apply (Apply (Prim Card_S) (Apply (Prim Card_K) f)) (Apply (Prim Card_K) x)
callresult t = cS [t, cI]
loop :: Term -> [Move]
loop cmd = store 0 (cS [cmd, callresult $ Prim Card_Get]) ++ c1 where
c1 = copyTo 1 0 ++ (MoveRight 0 Card_Zero):c1
copyTo :: Int -> Int -> [Move]
copyTo src dst = if (src == dst) then [] else storeInt dst src ++ [MoveLeft Card_Get dst]
store :: Int -> Term -> [Move]
store pos (Const n) = storeInt pos n
store pos (Apply (Prim c) t) = store pos t ++ [MoveLeft c pos]
store pos (Apply t (Prim c)) = store pos t ++ [MoveRight pos c]
store pos (Prim c) = [MoveLeft Card_Zero pos, MoveRight pos c]
store pos (Seq a b) = store pos (Apply (Apply (Apply (Prim Card_S) a) b) (Prim Card_Zero))
store pos (Apply a b) = if (pos == 0) then store 1 (Apply a b) ++ copyTo 1 0 else store pos a ++ store (pos+1) b ++ copyTo (pos+1) 0 ++ [MoveLeft Card_K pos, MoveLeft Card_S pos, MoveRight pos Card_Get, MoveRight pos Card_Zero]
printMove :: Move -> IO ()
printMove (MoveLeft c pos) = putStr ("1\n" ++ show c ++ "\n" ++ show pos ++ "\n") >> hFlush stdout
printMove (MoveRight pos c) = putStr ("2\n" ++ show pos ++ "\n" ++ show c ++ "\n") >> hFlush stdout
main = (mapM_ printMove $ loop (Prim Card_Dec)) >> mapM_ (const getLine) [0..]

4
run Executable file
View File

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