{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Rules (
runRules
,runner
,parseRule
,basicRules
,Rule(..)
,Priority(..)
,RuleId(..)
,ParseErrorId
,ParseErrorMsg)
where
import FRP.Yampa.Geometry
import Data.List
import Data.Function (on)
import Data.Maybe
import Object
import BasicTypes
import Message
import AL
import Helper
-- *************************************************************************
--
-- Framework for defining rules
--
-- ************************************************************************
concatMaybe :: Maybe [a] -> [a]
concatMaybe Nothing = []
concatMaybe (Just xs) = xs
uncollect :: [(a, [b])] -> [(a, b)]
uncollect = concatMap (\(a, bs) -> zip (repeat a) bs)
runRules' :: [ObjId] -> Facts -> [VisibleState] -> RuleBase -> [(ObjId, [(Priority, MessageBody)])]
runRules' teamMates' facts vss =
collect . map (\(p,(o,m)) -> (o, (p,m))) . uncollect
. map (\rule -> (opPriority rule, concatMaybe $ opRule rule teamMates' facts vss))
-- collect all the messages for each player that have the lowest prio
runRules :: [ObjId] -> Facts -> [VisibleState] -> RuleBase -> [(ObjId, MessageBody)]
runRules teamMates' facts vss =
concatMap (\(o, pms) ->
let pmsSort = sortBy (compare `on` fst) pms
lowest = fst $ head pmsSort
relevantMsgs = map snd $ takeWhile ((lowest ==) . fst) pmsSort
in zip (repeat o) relevantMsgs)
. runRules' teamMates' facts vss
-- *************************************************************************
--
-- Basic rules for all teams, not changeable by user
--
-- ************************************************************************
rule_kick_off :: RuleFunction
rule_kick_off _ facts vss = do
factKickOff facts []
att <- factAttacking facts []
FPTeam me <- factWhoAmI facts []
factEq facts [FPTeam me, att]
let x = if me == Home then 1 else (-1)
return $ [(vsObjId p, tm (TPTKickedOff, tspNull))| p <- teamPlayers Home vss ++ teamPlayers Away vss]
-- , vsObjId p /= ballCarrier]
++ [(vsObjId game, GameMessage (GTRunGame, (snd . vsGameState) game))]
++ [(ballCarrier, pm (PPTLoseMe, BSPShoot (x *^ (vector3 (-19) (-3) 0)))) | isJust bc]
where game = fetchGameVS vss
bc@(Just ballCarrier) = playerWithBall vss
-- Weitere Verbesserungsmöglichkeiten:
-- a. checken, dass nicht der einwerfende Spieler der erste ist, der den Ball wieder
-- aufnimmt
-- b. nicht sofort werfen, sondern eine halbe Sekunde oder so warten (vielleicht FactThrowinIn
-- erst dann einstellen, wenn eine Mindestzeit rum ist?) Sonst sieht es doof aus
-- c. der einwerfende Spieler soll in Richtung des Spots schauen, zu dem er werden will;
-- vielleicht wäre ein TS "AimingForThrowIn" gut
-- d. solange zielen (AimingForThrowIn), bis Güte des Spots über einen Schwellenwert
-- liegt ODER die Zeit seit Start der Einwurfaktion überschritten ist
rule_throw_in :: RuleFunction
rule_throw_in _ facts _ = do
FPPlayerId p <- factThrowingIn facts []
FPFromTo curr dest <- factBestPosition facts []
return $ (p, pm (PPTLoseMe,
#if DEBUG_MODE
trace ("RULE=" ++ show (BSPShoot (towards curr dest)) ++ show "; " ++ show dest)
#endif
BSPShoot (towards curr dest))) :
(1, GameMessage (GTBallInPlay, GPTeamPosition Home (-1) [] (Point2 0 0) 0 False InPlay)) :
[(p, tm (TPTReposition, tspNull))]
rule_stop_idling :: RuleFunction
rule_stop_idling _ facts _ = do
FPPlayers ps <- factIdling facts []
return $ map (\p -> (p, tm (TPTHoldPosition, tspNull))) ps
rule_punt :: RuleFunction
rule_punt _ facts _ = do
FPPlayerVector p v <- factPunt facts []
return $ [(p, pm (PPTLoseMe, BSPShoot v))]
-- was passiert beim Anstoß:
-- * 2 Spieler stehen am Anstoßpunkt
-- * ein Spieler hat den Ball
-- * auf Knopfdruck (bei eigenem Spieler) oder auf AI-Befehl geht der Ball von einem
-- auf den anderen Spieler über
-- * vorher kann sich keiner irgendwie drehen oder sonstwas
-- * Frage: Laufen dann alle in Position? Oder wird "neu aufgestellt?" Letzteres ist
-- wohl deutlich einfacher... Dann braucht es auch das ganze Status-Gehampel nicht...
-- * Frage: Ist man vor dem eigentlich Anstoß innerhalb der reactimate-Schleife oder
-- außerhalb?
-- PRO außerhalb: Ganz wenig Rumgehampel mit Status und Knorz (sonst muss mindestens mal
-- die handgesteuerten Spieler in einen Status versetzen, in dem er nicht
-- gesteuert werden kann AUSSER wenn er selber den Anstoß macht, dann ist der
-- einzige Steuerimpuls aber der Anstoß an sich)
-- CON außerhalb: Rendering und Keyboard-Knorzung muss noch mal gebastelt oder
-- mindestens mal angestoßen werden...
-- klingt so, als sollte man es erst mal mit innerhalb probieren...
basicRules :: [Rule]
basicRules = [Rule (RuleId (-1000)) "throw in" (Priority 1) rule_throw_in
,Rule (RuleId (-1001)) "kickoff" (Priority 0) rule_kick_off
,Rule (RuleId (-1002)) "punt" (Priority 4) rule_punt
,Rule (RuleId (-1003)) "stop idling" (Priority 10) rule_stop_idling
]
-- just some dummy stuff to later integrate more easily...
type Clause = Facts -> [FactParam] -> Maybe FactParam
type MsgMaker = [VisibleState] -> [FactParam] -> [Message]
type ParamId = Int
type Statement = [(Maybe ParamId, Clause, [RuleParam])]
data RuleParam = PId ParamId | PConst FactParam deriving (Show)
-- wrapper to run a parsed rule (set of clauses and message function)
runner :: Statement -> (MsgMaker, [RuleParam]) -> RuleFunction
runner clauses msgMaker myTeamMates facts vss =
run myTeamMates vss facts clauses msgMaker emptyAL
-- first runs a set of clauses and collects facts, then runs messaging function
-- lets only those messages through that are intended for own team (no cheating!)
run :: [ObjId] -> [VisibleState] -> Facts -> Statement ->
(MsgMaker, [RuleParam]) -> AL ParamId FactParam -> Maybe [Message]
run myTeamMates vss _ [] (msgMaker, params) paramFacts =
return $ filterTeam myTeamMates $ msgMaker vss $ fetchParams paramFacts params
run myTeamMates vss facts ((pId, clause, clauseParams):rs) msg paramFactsSoFar = do
fp <- clause facts $ fetchParams paramFactsSoFar clauseParams
run myTeamMates vss facts rs msg $ maybeInsertAL pId fp paramFactsSoFar
maybeInsertAL :: Maybe k -> a -> AL k a -> AL k a
maybeInsertAL Nothing _ paramFactsSoFar = paramFactsSoFar
maybeInsertAL (Just pId) fp paramFactsSoFar = insertAL pId fp paramFactsSoFar
filterTeam :: Eq a => [a] -> [(a, t)] -> [(a, t)]
filterTeam teamMates' =
filter (\(oid,_) -> elem oid teamMates')
fetchParams :: AL ParamId FactParam -> [RuleParam] -> [FactParam]
fetchParams _ [] = []
fetchParams pvs (p:ps) =
case p of
PId p' -> pvs ! p' : fetchParams pvs ps
PConst c -> c : fetchParams pvs ps
type ParamName = String
type RulePriority = Int
type ParseErrorId = Int
type ParseErrorMsg = String
parseRule :: [String] ->
Either (ParseErrorId, ParseErrorMsg)
(RuleName
,RulePriority
,Statement
,(MsgMaker, [RuleParam]))
parseRule ls = do
-- let ls = lines ruleString
let ln = length ls
checkRuleStructure ls
(ruleName, rulePrio) <- parseRuleHead (ls !! 0)
(clauses, params) <- gatherClauses (take (ln - 2) (tail ls)) []
(msg, msgParams) <- parseMsg (last ls) params
return (ruleName, rulePrio, clauses, (msg, msgParams))
checkRuleStructure :: Num t => [a] -> Either (t, String) ()
checkRuleStructure ls =
if length ls < 3 then
Left $ (10, "rule must consist of rule head, at least one clause and message")
else
Right ()
gatherClauses :: [String] -> [(ParamId, ParamName)] ->
Either (ParseErrorId, ParseErrorMsg)
(Statement, [(ParamId, ParamName)])
gatherClauses [c] acc = do
-- (Just (paramId, paramName), clause, params) <- parseClause c acc
(maybeVar, clause, params) <- parseClause c acc
return ([(fst `fmap` maybeVar, clause, params)], pushIfJust maybeVar acc)
gatherClauses (c:cs) acc = do
(maybeVar, clause, params) <- parseClause c acc
(restClauses, newAcc) <- gatherClauses cs (pushIfJust maybeVar acc)
return ((fst `fmap` maybeVar, clause, params) : restClauses, newAcc)
pushIfJust :: Maybe a -> [a] -> [a]
pushIfJust Nothing xs = xs
pushIfJust (Just x) xs = x : xs
parseRuleHead :: String -> Either (ParseErrorId, ParseErrorMsg)
(RuleName, RulePriority)
parseRuleHead rh =
let ws = words rh
in
if null ws || head ws /= "rule" || length ws /= 4 ||
ws !! 2 /= "priority" ||
null (reads (ws !! 3) :: [(Int, String)])
then Left (1, "rule head must be of form 'rule rulename priority xxx'")
else Right (ws !! 1, fst $ head (reads (ws !! 3) :: [(Int, String)]))
parseClause :: String -> [(ParamId, ParamName)] ->
Either (ParseErrorId, ParseErrorMsg)
(Maybe (ParamId, ParamName), Clause, [RuleParam])
parseClause clause params = do
let tokens = words clause
hasVar <- checkClauseStructure tokens
maybeVar <- checkVariable params (tokens !! 0) hasVar
fact <- checkFact (tokens !! (if hasVar then 2 else 1))
ps <- parseParams params (drop (if hasVar then 3 else 2) tokens)
return (maybeVar, fact, ps)
checkClauseStructure :: Num t => [String] -> Either (t, String) Bool
checkClauseStructure tokens =
if length tokens >= 3 && tokens !! 1 == "is"
then Right True
else if length tokens >= 2 && tokens !! 0 == "check"
then Right False
else Left (2, "clause must be of form 'var is fact params' or 'check fact params': " ++
concat (zipWith (++) tokens (repeat " ")))
checkVariable :: [(ParamId, ParamName)] -> String -> Bool ->
Either (ParseErrorId, ParseErrorMsg) (Maybe (ParamId, ParamName))
checkVariable params token True =
if elem token (map snd params)
then Left (2, "variable name already used: " ++ token)
else Right $ Just (newParamId params, token)
checkVariable _ _ False = Right Nothing
newParamId :: (Num a, Ord a) => [(a, b)] -> a
newParamId params =
if null params then 1
else 1 + (maximum $ map fst params)
parseParams :: Num t => [(ParamId, String)] -> [String] -> Either (t, String) [RuleParam]
parseParams _ [] = Right []
parseParams params ("scalar":tokens) = do
(scalar, rest) <- checkParamScalar tokens
result <- parseParams params rest
return $ (PConst (FPScalar scalar)) : result
parseParams params ("spot":tokens) = do
(x, y, rest) <- checkParamSpot tokens
result <- parseParams params rest
return $ (PConst (FPSpot $ Spot x y)) : result
parseParams params (paramName:tokens) = do
pid <- checkParamName params paramName
result <- parseParams params tokens
return $ (PId pid) : result
checkParamScalar :: Num t => [String] -> Either (t, String) (Double, [String])
checkParamScalar tokens =
if null tokens then Left (4, "unexpected end of clause after scalar keyword")
else if null (reads (head tokens) :: [(Double, String)])
then Left (5, "no number after scalar: " ++ head tokens)
else Right (fst $ head (reads (head tokens) :: [(Double, String)]), tail tokens)
checkParamSpot :: Num t => [String] -> Either (t, String) (Double, Double, [String])
checkParamSpot tokens =
if length tokens < 2 then Left (4, "unexpected end of clause after spot keyword")
else if null (reads (tokens !! 0) :: [(Double, String)]) ||
null (reads (tokens !! 1) :: [(Double, String)])
then Left (5, "no number after spot: " ++ (tokens !! 0) ++ ", " ++ (tokens !! 1))
else Right (fst $ head (reads (tokens !! 0) :: [(Double, String)]),
fst $ head (reads (tokens !! 1) :: [(Double, String)]),
drop 2 tokens)
checkParamName :: Num t => [(b, String)] -> String -> Either (t, String) b
checkParamName params paramName =
case find ((paramName ==) . snd) params of
Just (pid, _) -> Right pid
Nothing -> Left (6, "parameter not known: " ++ paramName)
parseMsg :: String -> [(ParamId, ParamName)] ->
Either (ParseErrorId, ParseErrorMsg)
(MsgMaker, [RuleParam])
parseMsg input params = do
let tokens = words input
checkMsgStructure tokens
msg <- checkMsg (tokens !! 1)
ps <- parseParams params (drop 2 tokens)
return (msg, ps)
checkMsgStructure :: Num t => [String] -> Either (t, String) ()
checkMsgStructure tokens =
if null tokens || length tokens < 2 ||
tokens !! 0 /= "send"
then Left (8, "message must be of form 'send msg params': " ++
concat (zipWith (++) tokens (repeat " ")))
else Right ()
checkMsg :: Num t => String -> Either (t, String) MsgMaker
checkMsg "msgKick" = Right msgKick
checkMsg "msgPassTo" = Right msgPassTo
checkMsg "msgIntercept" = Right msgIntercept
checkMsg x = Left (3, "no valid message: " ++ x)
checkFact :: String -> Either a (Facts -> FactFunction)
checkFact "factCanIntercept" = Right factCanIntercept
checkFact "factIsCloseTo" = Right factIsCloseTo
checkFact "factInLineWith" = Right factInLineWith
checkFact "factBestFreePlayer" = Right factBestFreePlayer
checkFact "factNearestAIPlayer" = Right factNearestAIPlayer
checkFact "factBallIsFree" = Right factBallIsFree
checkFact "factAttacking" = Right factAttacking
checkFact "factThrowingIn" = Right factThrowingIn
checkFact "factBestPosition" = Right factBestPosition
checkFact "factKickOff" = Right factKickOff
checkFact "factBallCarrier" = Right factBallCarrier
checkFact "factPlayerSpot" = Right factPlayerSpot
checkFact "factSpotValue" = Right factSpotValue
checkFact "factBestShootingVector" = Right factBestShootingVector
checkFact "factBestPassingVector" = Right factBestPassingVector
checkFact "factPunt" = Right factPunt
checkFact "factIdling" = Right factIdling
checkFact "factWhoAmI" = Right factWhoAmI
checkFact "factEq" = Right factEq
checkFact "factGT" = Right factGT
checkFact "factGetVector" = Right factGetVector
msgKick :: MsgMaker
msgKick _ [FPPlayerId ballCarrier, FPVector goalVector] =
[(ballCarrier, tm (TPTKickTowards,
(TacticalStateParam Nothing (Just goalVector)
False Nothing Nothing Nothing Nothing)))]
msgPassTo :: MsgMaker
msgPassTo _ [FPPlayerId ballCarrier, FPPlayerId receiver] =
[(ballCarrier, tm (TPTKickTowards,
(TacticalStateParam Nothing Nothing False
(Just receiver) Nothing (Just RTLow) Nothing)))]
msgIntercept :: MsgMaker
msgIntercept _ [FPPlayerId np, FPSpot p1] =
[(np, tm (TPTIntercept,
TacticalStateParam (Just $ spotToPoint p1) Nothing False Nothing Nothing Nothing Nothing))]