From 9e220ea36607216e39a455861e3aa99df6b2e53e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Stefan=20B=C3=BChler?= Date: Sat, 18 Jun 2011 11:57:31 +0200 Subject: [PATCH] next --- Eval.hs | 57 +++++++++++++++++++++++++++++++++---------------------- Lambda.hs | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++++ run | 4 ++++ 3 files changed, 93 insertions(+), 23 deletions(-) create mode 100644 Lambda.hs create mode 100755 run diff --git a/Eval.hs b/Eval.hs index d5e5ad4..9114d90 100644 --- a/Eval.hs +++ b/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 - - - - - - - - - - - - - - - diff --git a/Lambda.hs b/Lambda.hs new file mode 100644 index 0000000..ea6ee84 --- /dev/null +++ b/Lambda.hs @@ -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..] diff --git a/run b/run new file mode 100755 index 0000000..f69036d --- /dev/null +++ b/run @@ -0,0 +1,4 @@ +#!/bin/sh + +cd $(dirname $(readlink -f $0)) +exec runghc Lambda.hs