example corentins evaluator

gistfile1.hs

{-# 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