next
This commit is contained in:
Stefan Bühler
parent
bb6957abc0
commit
9e220ea366
57
Eval.hs
57
Eval.hs
@ -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
55
Lambda.hs
Normal 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..]
|
||||
Loading…
Reference in New Issue
Block a user