Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# LANGUAGE PackageImports #-}
- {-# LANGUAGE GADTs, StandaloneDeriving#-}
- import Control.Applicative
- import Control.Arrow
- import Control.Monad.Identity
- import Data.Typeable
- type PlayerNumber = Int
- type RuleNumber = Int
- type Game = Int
- type Comm = Int
- type Action = Int
- type Actions = [Action]
- data EvaluatorT m a = EvaluatorT (Game -> m (Game, Either Actions a))
- type EvaluatorIO a = EvaluatorT IO a
- type Evaluator a = EvaluatorT Identity a
- runEvaluator (EvaluatorT f) game = f game
- execEvaluator e g = fmap fst $ runEvaluator e g
- evalEvaluator e g = fmap snd $ runEvaluator e g
- instance Functor m => Functor (EvaluatorT m) where
- f `fmap` e = EvaluatorT $ fmap (second $ right f) . runEvaluator e
- -- Applicative instances with different semantics in Game-State handling
- -- on Left values
- -- instance (Monad m, Applicative m) => Applicative (EvaluatorT m) where
- -- pure a = EvaluatorT $ \g -> pure (g, Right a)
- -- ef <*> ev = EvaluatorT $ \g -> do
- -- (g', resf) <- runEvaluator ef g
- -- (g'', resv) <- runEvaluator ev g'
- -- return $ case (resf, resv) of
- -- (Left a1, Left a2) -> (g, Left (a1 ++ a2))
- -- (Left a , _ ) -> (g, Left a)
- -- (_ , Left a ) -> (g, Left a)
- -- (Right f, Right v) -> (g'', Right $ f v)
- instance (Monad m, Applicative m) => Applicative (EvaluatorT m) where
- pure a = EvaluatorT $ \g -> pure (g, Right a)
- ef <*> ev = EvaluatorT $ \g -> do
- (g', resf) <- runEvaluator ef g
- case resf of
- Left a1 -> do resv <- evalEvaluator ev g
- return $ case resv of
- Left a2 -> (g, Left (a1 ++ a2))
- Right _ -> (g, Left a1)
- Right f -> do (g'', resv) <- runEvaluator ev g'
- return $ case resv of
- Left a -> (g, Left a)
- Right v -> (g'', Right $ f v)
- instance (Monad m) => Monad (EvaluatorT m) where
- return a = EvaluatorT $ \g -> return (g, Right a)
- ma >>= f = EvaluatorT $ \g -> do
- (g', resa) <- runEvaluator ma g
- case resa of
- Right a -> runEvaluator (f a) g'
- Left acts -> return (g', Left acts)
- data Obs a where
- ProposedBy :: Obs PlayerNumber
- RuleNumber :: Obs RuleNumber
- SelfNumber :: Obs RuleNumber
- Official :: Obs Bool
- AllPlayers :: Obs [PlayerNumber]
- Equ :: (Eq a, Show a, Typeable a) => Obs a -> Obs a -> Obs Bool
- Plus :: (Num a) => Obs a -> Obs a -> Obs a
- Time :: (Num a) => Obs a -> Obs a -> Obs a
- Minus :: (Num a) => Obs a -> Obs a -> Obs a
- And :: Obs Bool -> Obs Bool -> Obs Bool
- Or :: Obs Bool -> Obs Bool -> Obs Bool
- Not :: Obs Bool -> Obs Bool
- If :: Obs Bool -> Obs a -> Obs a -> Obs a
- Konst :: a -> Obs a
- Map :: (Obs a -> Obs b) -> Obs [a] -> Obs [b]
- Foldr :: (Obs a -> Obs b -> Obs b) -> Obs b -> Obs [a] -> Obs b
- Vote :: Obs String -> Obs Int -> Obs Bool
- evalOp2 o a b = o <$> eval a <*> eval b
- eval :: (Monad m,Applicative m) => Obs a -> EvaluatorT m a
- eval (Konst a) = return a
- eval (Equ a b) = evalOp2 (==) a b
- eval (Plus a b) = evalOp2 (+) a b
- eval (Time a b) = evalOp2 (*) a b
- eval (Minus a b) = evalOp2 (-) a b
- eval (And a b) = evalOp2 (&&) a b
- eval (Or a b) = evalOp2 (||) a b
- eval (Not a) = not <$> eval a
- eval (If ot oa ob) = do t <- eval ot; eval $ if t then oa else ob
- eval (Map f lst) = join (evalSequence <$> map (eval.f.Konst) <$> eval lst)
- eval (Foldr f init lst) = join (eval <$> foldr (f.Konst) init <$> eval lst)
- -- evalSequence with different semantics using either monadic instance of the
- -- applicative one
- evalSequence :: (Applicative m, Monad m) => [EvaluatorT m a] -> EvaluatorT m [a]
- -- evalSequence = sequence -- this one uses the monadic interface
- evalSequence [] = pure [] -- and this one uses the applicative one
- evalSequence (x:xs) = (:) <$> x <*> evalSequence xs
Add Comment
Please, Sign In to add comment