This commit is contained in:
Stefan Bühler 2011-06-18 13:26:32 +02:00
parent e9b17b8ab2
commit 0ddd95852e
2 changed files with 25 additions and 9 deletions

25
Eval.hs
View File

@ -9,6 +9,7 @@ module Eval (
Value (..), Value (..),
Card (..), Card (..),
cardNames, cardNames,
pCard,
Move (..), Move (..),
card, card,
initGame, initGame,
@ -22,6 +23,9 @@ import qualified Data.Array.IO as A
import System.IO.Unsafe import System.IO.Unsafe
import Data.Maybe import Data.Maybe
import Text.ParserCombinators.ReadP
import Data.Char
type Field = (Value, Int) type Field = (Value, Int)
type Fields = A.IOArray Int Field type Fields = A.IOArray Int Field
data Player = Player { fields :: Fields } deriving (Show, Eq) data Player = Player { fields :: Fields } deriving (Show, Eq)
@ -40,6 +44,7 @@ data Card = Card_I | Card_Zero | Card_Succ | Card_Dbl | Card_Get | Card_Put | Ca
data Move = MoveLeft Card Int | MoveRight Int Card 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")] 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")]
cardNamesX = map (\(a,b) -> (b,a)) cardNames
instance Monad Turn where 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) (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)
@ -71,8 +76,24 @@ instance Show Card where
show c = fromJust $ lookup c cardNames show c = fromJust $ lookup c cardNames
instance Show Move where instance Show Move where
show (MoveLeft c pos) = (show c) ++ " >> " ++ (show pos) show (MoveLeft c pos) = (show c) ++ " " ++ (show pos)
show (MoveRight pos c) = (show pos) ++ " << " ++ (show c) show (MoveRight pos c) = (show pos) ++ " " ++ (show c)
pCard :: ReadP Card
pCard = do
s <- many1 (satisfy isAlpha)
case lookup s cardNamesX of
Just c -> return c
Nothing -> pfail
pmPos = readS_to_P reads >>= \i -> if (i >= 0 && i <= 255) then return i else pfail
pMove = skipSpaces >> ((do c <- pCard; skipSpaces; pos <- pmPos; skipSpaces; return $ MoveLeft c pos) <++ (do pos <- pmPos; skipSpaces; c <- pCard; skipSpaces; return $ MoveRight pos c))
instance Read Card where
readsPrec _ = readP_to_S pCard
instance Read Move where
readsPrec _ = readP_to_S pMove
take1 :: String -> (Value -> Turn Value) -> Value take1 :: String -> (Value -> Turn Value) -> Value
take1 name f = ValFunction name $ \v -> apply 1 >> f v take1 name f = ValFunction name $ \v -> apply 1 >> f v

View File

@ -10,17 +10,12 @@ import Control.Monad
data Term = Const Int | Prim Card | Seq Term Term | Apply Term Term data Term = Const Int | Prim Card | Seq Term Term | Apply Term Term
cardNamesX = map (\(a,b) -> (b,a)) cardNames
ptConst :: ReadP Term ptConst :: ReadP Term
ptConst = readS_to_P reads >>= return . Const ptConst = readS_to_P reads >>= return . Const
ptPrim = do ptPrim = do
c <- satisfy isAlpha c <- pCard
s' <- many (satisfy isAlpha) return $ Prim c
let s = c:s'
case lookup s cardNamesX of
Just c -> return $ Prim c
Nothing -> pfail
ptGroup = do ptGroup = do
char '(' char '('
t <- ptTerm t <- ptTerm