next

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,15 +36,17 @@ 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 :: IO x -> Turn x
 liftIO f = Turn $ \game -> f >>= \x -> return (game, Right x)
 
 apply :: Int -> Turn ()
@@ -49,6 +67,13 @@ 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
@@ -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
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

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..]

run

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