From 0ddd95852e652a7e9f5bbb8c6eb9f2ea0c04b76f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Stefan=20B=C3=BChler?= <stbuehler@web.de>
Date: Sat, 18 Jun 2011 13:26:32 +0200
Subject: [PATCH] parsers

---
 Eval.hs   | 25 +++++++++++++++++++++++--
 Lambda.hs |  9 ++-------
 2 files changed, 25 insertions(+), 9 deletions(-)

diff --git a/Eval.hs b/Eval.hs
index 9114d90..10bd58f 100644
--- a/Eval.hs
+++ b/Eval.hs
@@ -9,6 +9,7 @@ module Eval (
 	Value (..),
 	Card (..),
 	cardNames,
+	pCard,
 	Move (..),
 	card,
 	initGame,
@@ -22,6 +23,9 @@ import qualified Data.Array.IO as A
 import System.IO.Unsafe
 import Data.Maybe
 
+import Text.ParserCombinators.ReadP
+import Data.Char
+
 type Field = (Value, Int)
 type Fields = A.IOArray Int Field
 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
 
 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
 	(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
 
 instance Show Move where
-	show (MoveLeft c pos) = (show c) ++ " >> " ++ (show pos)
-	show (MoveRight pos c) = (show pos) ++ " << " ++ (show c)
+	show (MoveLeft c pos) = (show c) ++ " " ++ (show pos)
+	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 name f = ValFunction name $ \v -> apply 1 >> f v
diff --git a/Lambda.hs b/Lambda.hs
index f1653d7..8492735 100644
--- a/Lambda.hs
+++ b/Lambda.hs
@@ -10,17 +10,12 @@ import Control.Monad
 
 data Term = Const Int | Prim Card | Seq Term Term | Apply Term Term
 
-cardNamesX = map (\(a,b) -> (b,a)) cardNames
 
 ptConst :: ReadP Term
 ptConst = readS_to_P reads >>= return . Const
 ptPrim = do
-	c <- satisfy isAlpha
-	s' <- many (satisfy isAlpha)
-	let s = c:s'
-	case lookup s cardNamesX of
-		Just c -> return $ Prim c
-		Nothing -> pfail
+	c <- pCard
+	return $ Prim c
 ptGroup = do
 	char '('
 	t <- ptTerm