You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

Eval.hs 10KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276
  1. {-# OPTIONS -XTypeSynonymInstances #-}
  2. module Eval (
  3. Game (..),
  4. Player (..),
  5. Fields,
  6. Field,
  7. Turn (..),
  8. Value (..),
  9. Card (..),
  10. MonadIO (..),
  11. cardNames,
  12. pCard,
  13. Move (..),
  14. card,
  15. initGame,
  16. getGame,
  17. try,
  18. runMove,
  19. runTurn,
  20. testMoves,
  21. testMoves1
  22. ) where
  23. import Control.Monad
  24. import qualified Data.Array.IO as A
  25. import System.IO
  26. import System.IO.Unsafe
  27. import Data.Maybe
  28. import Text.ParserCombinators.ReadP
  29. import Data.Char
  30. type Field = (Value, Int)
  31. type Fields = A.IOArray Int Field
  32. data Player = Player { fields :: Fields } deriving (Show, Eq)
  33. data AIState = AIState deriving (Show, Eq)
  34. data Game = Game { proponent, opponent :: Player, applications :: Int, automode :: Bool, gameturn :: Integer, aistate :: AIState } deriving (Show, Eq)
  35. data Turn x = Turn { runTurn' :: Game -> IO (Game, Either String x) }
  36. data Value = ValInt !Int | ValFunction String (Value -> Turn Value)
  37. vitality :: Int -> Int
  38. vitality x = if (x < 0) then 0 else if (x > 65535) then 65535 else x
  39. int :: Int -> Value
  40. int x = ValInt $ vitality x
  41. 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)
  42. data Move = MoveLeft Card Int | MoveRight Int Card
  43. 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")]
  44. cardNamesX = map (\(a,b) -> (b,a)) cardNames
  45. instance Monad Turn where
  46. (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)
  47. return x = Turn $ \game -> return (game, Right x)
  48. fail s = Turn $ \game -> return (game, Left s)
  49. class Monad m => MonadIO m where
  50. liftIO :: IO x -> m x
  51. instance MonadIO Turn where
  52. liftIO f = Turn $ \game -> f >>= \x -> return (game, Right x)
  53. modifyGame :: (Game -> Game) -> Turn ()
  54. modifyGame f = Turn $ \game -> return (f game, Right ())
  55. getGame :: Turn Game
  56. getGame = Turn $ \game -> return (game, Right game)
  57. switchPlayer :: Turn ()
  58. switchPlayer = modifyGame $ \game -> game { proponent = opponent game, opponent = proponent game, gameturn = 1 + gameturn game }
  59. apply :: Int -> Turn ()
  60. 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 ())
  61. reset :: Turn ()
  62. reset = modifyGame $ \game -> game {applications = 0}
  63. try :: Turn x -> (String -> Turn y) -> Turn ()
  64. try (Turn action) catch = Turn $ \game -> (action game >>=) $ \(game', r) -> case r of Right _ -> return (game', Right ()); Left s -> case catch s of Turn catch' -> catch' game' >>= (\(game'', r) -> case r of Right _ -> return (game'', Right ()); Left s -> return (game'', Left s))
  65. instance Show Value where
  66. show (ValInt i) = show i
  67. show (ValFunction name _) = name
  68. instance Show Fields where
  69. show f = unsafePerformIO $ do
  70. assocs <- A.getAssocs f
  71. return $ show $ filter (\(_, (val, vit)) -> vit /= 10000 || (show val /= "I")) assocs
  72. instance Show Card where
  73. show c = fromJust $ lookup c cardNames
  74. instance Show Move where
  75. show (MoveLeft c pos) = (show c) ++ " " ++ (show pos)
  76. show (MoveRight pos c) = (show pos) ++ " " ++ (show c)
  77. pCard :: ReadP Card
  78. pCard = do
  79. s <- many1 (satisfy isAlpha)
  80. case lookup s cardNamesX of
  81. Just c -> return c
  82. Nothing -> pfail
  83. pmPos = readS_to_P reads >>= \i -> if (i >= 0 && i <= 255) then return i else pfail
  84. pMove = skipSpaces >> ((do c <- pCard; skipSpaces; pos <- pmPos; skipSpaces; return $ MoveLeft c pos) <++ (do pos <- pmPos; skipSpaces; c <- pCard; skipSpaces; return $ MoveRight pos c))
  85. instance Read Card where
  86. readsPrec _ = readP_to_S pCard
  87. instance Read Move where
  88. readsPrec _ = readP_to_S pMove
  89. take1 :: String -> (Value -> Turn Value) -> Value
  90. take1 name f = ValFunction name $ \v -> apply 1 >> f v
  91. take2 :: String -> (Value -> Value -> Turn Value) -> Value
  92. take2 name f = ValFunction name $ \v -> apply 1 >> return (take1 (name ++ "(" ++ show v ++ ")") (f v))
  93. take3 :: String -> (Value -> Value -> Value -> Turn Value) -> Value
  94. take3 name f = ValFunction name $ \v -> apply 1 >> return (take2 (name ++ "(" ++ show v ++ ")") (f v))
  95. getInt :: Value -> Turn Int
  96. getInt v = case v of ValInt x -> return x; _ -> fail "Expected Integer, got Function"
  97. getSlotNo :: Value -> Turn Int
  98. getSlotNo = getInt >=> \slot -> if (slot >= 0 && slot <= 255) then return slot else fail ("Invalid slot index " ++ (show slot))
  99. getFunc :: Value -> Turn (Value -> Turn Value)
  100. getFunc v = case v of ValFunction _ x -> return x; _ -> fail "Expected Function, got Integer"
  101. tryApply :: Value -> Value -> Turn Value
  102. tryApply f v = case f of ValFunction _ f' -> f' v; _ -> fail "Expected Function, got Integer"
  103. readSlot :: (Game -> Player) -> Int -> Turn (Int, Field)
  104. readSlot player n = Turn $ \game -> A.readArray (fields $ player game) n >>= \field -> return (game, Right (n, field))
  105. writeSlot :: (Game -> Player) -> Int -> Field -> Turn ()
  106. writeSlot player n field = Turn $ \game -> A.writeArray (fields $ player game) n field >> return (game, Right ())
  107. writeValue :: (Game -> Player) -> Int -> Value -> Turn ()
  108. writeValue player n val = readSlot player n >>= \(_, (_, vit)) -> writeSlot player n (val, vit)
  109. getSlot :: (Game -> Player) -> Value -> Turn (Int, Field)
  110. getSlot player = getSlotNo >=> readSlot player
  111. getAliveSlot :: (Game -> Player) -> Value -> Turn (Int, Field)
  112. getAliveSlot player = getSlot player >=> \r@(slot, (_, vit)) -> if (vit > 0) then return r else fail ("Slot " ++ (show slot) ++ " not alive")
  113. autoSwitch :: Turn () -> Turn () -> Turn Value
  114. autoSwitch (Turn norm) (Turn aut) = (Turn $ \game -> if (automode game) then aut game else norm game) >> return (card Card_I)
  115. healSlot :: (Game -> Player) -> Int -> Int -> Turn ()
  116. healSlot player amount slot = do
  117. (_, (val, vit)) <- readSlot player slot
  118. when (vit > 0) (writeSlot player slot (val, vitality $ vit + amount))
  119. pierceSlot :: (Game -> Player) -> Int -> Int -> Turn ()
  120. pierceSlot player amount slot = do
  121. (_, (val, vit)) <- readSlot player slot
  122. when (vit > 0) (writeSlot player slot (val, vitality $ vit - amount))
  123. reviveSlot :: (Game -> Player) -> Int -> Turn ()
  124. reviveSlot player slot = do
  125. (_, (val, vit)) <- readSlot player slot
  126. when (vit <= 0) (writeSlot player slot (val, 1))
  127. card :: Card -> Value
  128. card Card_I = take1 "I" $ return
  129. card Card_Zero = ValInt 0
  130. card Card_Succ = take1 "succ" $ getInt >=> return . int . (+1)
  131. card Card_Dbl = take1 "dbl" $ getInt >=> return . int . (*2)
  132. card Card_Get = take1 "get" $ getAliveSlot proponent >=> \(_, (val, _)) -> return val
  133. card Card_Put = take1 "put" $ const $ return $ card Card_I
  134. card Card_S = take3 "S" $ \f g x -> do
  135. h <- tryApply f x
  136. y <- tryApply g x
  137. tryApply h y
  138. card Card_K = take2 "K" $ \x _ -> return x
  139. card Card_Inc = take1 "inc" $ getSlotNo >=> \slot -> autoSwitch (healSlot proponent 1 slot) (pierceSlot proponent 1 slot)
  140. card Card_Dec = take1 "dec" $ getSlotNo >=> \slot -> autoSwitch (pierceSlot opponent 1 (255-slot)) (healSlot opponent 1 (255-slot))
  141. card Card_Attack = take3 "attack" $ \i j n -> do
  142. i <- getSlotNo i
  143. n <- getInt n
  144. autoSwitch (do
  145. (_, (_, vit)) <- readSlot proponent i
  146. when (vit < n) $ fail "Attack: not enough vitality"
  147. pierceSlot proponent n i
  148. j <- getSlotNo j
  149. pierceSlot opponent ((n*9) `div` 10) (255-j)
  150. ) (do
  151. (_, (_, vit)) <- readSlot proponent i
  152. when (vit < n) $ fail "Attack: not enough vitality"
  153. pierceSlot proponent n i
  154. j <- getSlotNo j
  155. healSlot opponent ((n*9) `div` 10) (255-j)
  156. )
  157. card Card_Help = take3 "help" $ \i j n -> do
  158. i <- getSlotNo i
  159. n <- getInt n
  160. autoSwitch (do
  161. (_, (_, vit)) <- readSlot proponent i
  162. when (vit < n) $ fail "Help: not enough vitality"
  163. pierceSlot proponent n i
  164. j <- getSlotNo j
  165. healSlot proponent ((n*11) `div` 10) (255-j)
  166. ) (do
  167. (_, (_, vit)) <- readSlot proponent i
  168. when (vit < n) $ fail "Help: not enough vitality"
  169. pierceSlot proponent n i
  170. j <- getSlotNo j
  171. pierceSlot proponent ((n*11) `div` 10) (255-j)
  172. )
  173. card Card_Copy = take1 "copy" $ getSlotNo >=> readSlot opponent >=> \(_, (val, _)) -> return val
  174. card Card_Revive = take1 "revive" $ getSlotNo >=> reviveSlot proponent >=> const (return $ card Card_I)
  175. card Card_Zombie = take2 "zombie" $ \i x -> do
  176. i <- getSlotNo i
  177. (_, (_, vit)) <- readSlot opponent (255-i)
  178. when (vit > 0) $ fail "Zombie: slot is still alive"
  179. writeSlot opponent (255-i) (x, -1)
  180. return $ card Card_I
  181. runauto :: Turn ()
  182. runauto = do
  183. modifyGame $ \game -> game { automode = True }
  184. forM_ [0..255] $ \slot -> do
  185. (_, (val, vit)) <- readSlot proponent slot
  186. when (vit == -1) $ do
  187. try (reset >> tryApply val (card Card_I)) (\s -> liftIO $ hPutStrLn stderr $ "Error for zombie " ++ (show slot) ++ ": " ++ s)
  188. writeSlot proponent slot (card Card_I, 0)
  189. modifyGame $ \game -> game { automode = False }
  190. runMove :: Move -> Turn ()
  191. runMove m = do
  192. runauto
  193. try (do
  194. (l, r, field) <- getmove m
  195. reset
  196. try (tryApply l r >>= writeValue proponent field) (\s -> do
  197. writeValue proponent field (card Card_I)
  198. liftIO (hPutStrLn stderr $ "Error: " ++ s))
  199. ) (\s -> liftIO (hPutStrLn stderr $ "Fatal Error in '" ++ show m ++ "': " ++ s))
  200. getGame >>= \game -> liftIO $ hPutStrLn stderr (show game)
  201. switchPlayer
  202. where
  203. getmove :: Move -> Turn (Value, Value, Int)
  204. getmove (MoveLeft crd field) = do
  205. (_, (f, _)) <- getAliveSlot proponent (ValInt field)
  206. return (card crd, f, field)
  207. getmove (MoveRight field crd) = do
  208. (_, (f, _)) <- getAliveSlot proponent (ValInt field)
  209. return (f, card crd, field)
  210. initFields :: IO Fields
  211. initFields = A.newArray (0, 255) (card Card_I, 10000)
  212. initPlayer :: IO Player
  213. initPlayer = initFields >>= return . Player
  214. initAIState = return AIState
  215. initGame :: IO Game
  216. initGame = do
  217. p0 <- initPlayer
  218. p1 <- initPlayer
  219. ai <- initAIState
  220. return $ Game p0 p1 0 False 0 ai
  221. runTurn :: Turn () -> Game -> IO Game
  222. runTurn turn game = runTurn' turn game >>= \res -> case res of
  223. (game', Left s) -> (hPutStrLn stderr $ "Error in turn: " ++ s) >> return game
  224. (game', Right _) -> return game
  225. runMoves :: [Move] -> Game -> IO Game
  226. runMoves moves game = foldM (flip runTurn) game $ map runMove moves
  227. testMoves :: [Move] -> IO Game
  228. testMoves moves = initGame >>= runMoves moves
  229. testMoves1 :: [Move] -> IO Game
  230. testMoves1 moves = initGame >>= \game -> foldM (\g t -> runTurn (t >> switchPlayer) g) game $ map runMove moves